From 9dfe12ae5b94d03c997ea2903022a5d2d5c5f266 Mon Sep 17 00:00:00 2001 From: charlet Date: Tue, 21 Oct 2003 13:42:24 +0000 Subject: 2003-10-21 Arnaud Charlet * 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 --- gcc/ada/1ic.ads | 2 +- gcc/ada/31soccon.ads | 201 +- gcc/ada/31soliop.ads | 13 +- gcc/ada/3asoccon.ads | 201 +- gcc/ada/3bsoccon.ads | 201 +- gcc/ada/3gsoccon.ads | 201 +- gcc/ada/3hsoccon.ads | 201 +- gcc/ada/3psoccon.ads | 158 ++ gcc/ada/3ssoccon.ads | 201 +- gcc/ada/3ssoliop.ads | 13 +- gcc/ada/3veacodu.adb | 73 + gcc/ada/3vexpect.adb | 1187 +++++++++++ gcc/ada/3vsoccon.ads | 158 ++ gcc/ada/3vsocthi.adb | 577 ++++++ gcc/ada/3vsocthi.ads | 445 +++++ gcc/ada/3vtrasym.adb | 185 ++ gcc/ada/3wsoccon.ads | 220 +- gcc/ada/3wsocthi.adb | 339 +++- gcc/ada/3wsocthi.ads | 161 +- gcc/ada/3wsoliop.ads | 14 +- gcc/ada/3zsoccon.ads | 158 ++ gcc/ada/3zsocthi.adb | 632 ++++++ gcc/ada/3zsocthi.ads | 446 +++++ gcc/ada/41intnam.ads | 2 +- gcc/ada/42intnam.ads | 2 +- gcc/ada/4aintnam.ads | 2 +- gcc/ada/4cintnam.ads | 2 +- gcc/ada/4dintnam.ads | 97 - gcc/ada/4gintnam.ads | 20 +- gcc/ada/4hexcpol.adb | 2 +- gcc/ada/4hintnam.ads | 16 +- gcc/ada/4lintnam.ads | 2 +- gcc/ada/4mintnam.ads | 145 -- gcc/ada/4nintnam.ads | 2 +- gcc/ada/4ointnam.ads | 8 +- gcc/ada/4onumaux.ads | 2 +- gcc/ada/4pintnam.ads | 2 +- gcc/ada/4sintnam.ads | 2 +- gcc/ada/4uintnam.ads | 154 -- gcc/ada/4vcaldel.adb | 8 +- gcc/ada/4vcalend.adb | 43 +- gcc/ada/4vintnam.ads | 2 +- gcc/ada/4wexcpol.adb | 2 +- gcc/ada/4wintnam.ads | 4 +- gcc/ada/4zintnam.ads | 2 +- gcc/ada/50system.ads | 163 ++ gcc/ada/51osinte.adb | 2 +- gcc/ada/51osinte.ads | 2 +- gcc/ada/51system.ads | 150 ++ gcc/ada/52osinte.adb | 8 +- gcc/ada/52osinte.ads | 8 +- gcc/ada/52system.ads | 138 -- gcc/ada/53osinte.ads | 2 +- gcc/ada/54osinte.ads | 5 +- gcc/ada/55system.ads | 150 ++ gcc/ada/56osinte.adb | 154 ++ gcc/ada/56osinte.ads | 584 ++++++ gcc/ada/56taprop.adb | 1201 +++++++++++ gcc/ada/56taspri.ads | 97 + gcc/ada/56tpopsp.adb | 110 + gcc/ada/57system.ads | 150 ++ gcc/ada/58system.ads | 150 ++ gcc/ada/59system.ads | 164 ++ gcc/ada/5aml-tgt.adb | 385 ++++ gcc/ada/5aosinte.adb | 2 +- gcc/ada/5aosinte.ads | 2 +- gcc/ada/5asystem.ads | 15 +- gcc/ada/5ataprop.adb | 254 ++- gcc/ada/5atasinf.ads | 24 +- gcc/ada/5ataspri.ads | 2 +- gcc/ada/5atpopsp.adb | 194 +- gcc/ada/5avxwork.ads | 2 +- gcc/ada/5bml-tgt.adb | 398 ++++ gcc/ada/5bosinte.adb | 23 +- gcc/ada/5bosinte.ads | 2 +- gcc/ada/5bsystem.ads | 15 +- gcc/ada/5cosinte.ads | 2 +- gcc/ada/5csystem.ads | 160 ++ gcc/ada/5dosinte.ads | 536 ----- gcc/ada/5dsystem.ads | 158 ++ gcc/ada/5esystem.ads | 15 +- gcc/ada/5etpopse.adb | 51 - gcc/ada/5fintman.adb | 94 +- gcc/ada/5fosinte.adb | 120 ++ gcc/ada/5fosinte.ads | 2 +- gcc/ada/5fsystem.ads | 15 +- gcc/ada/5ftaprop.adb | 204 +- gcc/ada/5ftasinf.ads | 24 +- gcc/ada/5ginterr.adb | 14 +- gcc/ada/5gintman.adb | 97 +- gcc/ada/5gmastop.adb | 12 +- gcc/ada/5gml-tgt.adb | 368 ++++ gcc/ada/5gosinte.ads | 2 +- gcc/ada/5gproinf.ads | 3 +- gcc/ada/5gsystem.ads | 24 +- gcc/ada/5gtaprop.adb | 75 +- gcc/ada/5gtasinf.ads | 23 +- gcc/ada/5gtpgetc.adb | 2 +- gcc/ada/5hml-tgt.adb | 373 ++++ gcc/ada/5hosinte.adb | 21 +- gcc/ada/5hosinte.ads | 8 +- gcc/ada/5hparame.ads | 14 +- gcc/ada/5hsystem.ads | 15 +- gcc/ada/5htaprop.adb | 213 +- gcc/ada/5htaspri.ads | 2 +- gcc/ada/5htraceb.adb | 16 +- gcc/ada/5iosinte.adb | 8 +- gcc/ada/5isystem.ads | 166 ++ gcc/ada/5itaprop.adb | 275 ++- gcc/ada/5itaspri.ads | 2 +- gcc/ada/5ksystem.ads | 15 +- gcc/ada/5kvxwork.ads | 2 +- gcc/ada/5lintman.adb | 111 +- gcc/ada/5lml-tgt.adb | 274 +-- gcc/ada/5losinte.ads | 2 +- gcc/ada/5lparame.adb | 73 + gcc/ada/5lsystem.ads | 21 +- gcc/ada/5mosinte.ads | 559 ------ gcc/ada/5msystem.ads | 158 ++ gcc/ada/5mvxwork.ads | 2 +- gcc/ada/5ninmaop.adb | 2 +- gcc/ada/5nintman.adb | 2 +- gcc/ada/5nosinte.ads | 2 +- gcc/ada/5ntaprop.adb | 22 +- gcc/ada/5ntaspri.ads | 2 +- gcc/ada/5ointerr.adb | 8 +- gcc/ada/5omastop.adb | 2 +- gcc/ada/5oosinte.adb | 8 +- gcc/ada/5oosinte.ads | 8 +- gcc/ada/5oosprim.adb | 2 +- gcc/ada/5oparame.adb | 2 +- gcc/ada/5osystem.ads | 15 +- gcc/ada/5otaprop.adb | 75 +- gcc/ada/5otaspri.ads | 8 +- gcc/ada/5posinte.ads | 2 +- gcc/ada/5posprim.adb | 38 +- gcc/ada/5psystem.ads | 150 ++ gcc/ada/5pvxwork.ads | 2 +- gcc/ada/5qosinte.adb | 48 - gcc/ada/5qosinte.ads | 186 -- gcc/ada/5qstache.adb | 77 - gcc/ada/5qtaprop.adb | 1776 ----------------- gcc/ada/5qtaspri.ads | 138 -- gcc/ada/5sintman.adb | 87 +- gcc/ada/5sml-tgt.adb | 367 ++++ gcc/ada/5sosinte.adb | 8 +- gcc/ada/5sosinte.ads | 2 +- gcc/ada/5sosprim.adb | 124 ++ gcc/ada/5ssystem.ads | 15 +- gcc/ada/5staprop.adb | 653 +++--- gcc/ada/5stasinf.ads | 24 +- gcc/ada/5staspri.ads | 2 +- gcc/ada/5stpopse.adb | 204 -- gcc/ada/5stpopsp.adb | 109 + gcc/ada/5svxwork.ads | 2 +- gcc/ada/5tosinte.ads | 2 +- gcc/ada/5tsystem.ads | 236 +++ gcc/ada/5uintman.adb | 257 --- gcc/ada/5uosinte.ads | 552 ----- gcc/ada/5usystem.ads | 150 ++ gcc/ada/5vasthan.adb | 49 +- gcc/ada/5vinmaop.adb | 42 +- gcc/ada/5vinterr.adb | 137 +- gcc/ada/5vintman.adb | 4 +- gcc/ada/5vintman.ads | 6 +- gcc/ada/5vmastop.adb | 86 +- gcc/ada/5vml-tgt.adb | 571 ++++++ gcc/ada/5vosinte.adb | 8 +- gcc/ada/5vosinte.ads | 2 +- gcc/ada/5vosprim.adb | 2 +- gcc/ada/5vparame.ads | 14 +- gcc/ada/5vsymbol.adb | 528 +++++ gcc/ada/5vsystem.ads | 15 +- gcc/ada/5vtaprop.adb | 197 +- gcc/ada/5vtaspri.ads | 2 +- gcc/ada/5vtpopde.adb | 32 +- gcc/ada/5vtpopde.ads | 6 +- gcc/ada/5vtraent.adb | 77 + gcc/ada/5vtraent.ads | 68 + gcc/ada/5wgloloc.adb | 3 +- gcc/ada/5wintman.adb | 4 +- gcc/ada/5wmemory.adb | 8 +- gcc/ada/5wml-tgt.adb | 354 ++++ gcc/ada/5wosprim.adb | 119 +- gcc/ada/5wsystem.ads | 24 +- gcc/ada/5wtaprop.adb | 360 ++-- gcc/ada/5wtaspri.ads | 9 +- gcc/ada/5xparame.ads | 203 ++ gcc/ada/5xsystem.ads | 236 +++ gcc/ada/5xvxwork.ads | 54 + gcc/ada/5yparame.ads | 203 ++ gcc/ada/5ysystem.ads | 22 +- gcc/ada/5ytiitho.adb | 66 + gcc/ada/5zinit.adb | 285 +++ gcc/ada/5zinterr.adb | 35 +- gcc/ada/5zintman.adb | 50 +- gcc/ada/5zml-tgt.adb | 322 +++ gcc/ada/5zosinte.adb | 6 +- gcc/ada/5zosinte.ads | 21 +- gcc/ada/5zosprim.adb | 30 +- gcc/ada/5zparame.ads | 203 ++ gcc/ada/5zsystem.ads | 22 +- gcc/ada/5ztaprop.adb | 464 +++-- gcc/ada/5ztaspri.ads | 95 + gcc/ada/5ztfsetr.adb | 107 + gcc/ada/5zthrini.adb | 113 ++ gcc/ada/5ztiitho.adb | 52 + gcc/ada/5ztpopsp.adb | 74 + gcc/ada/6vcpp.adb | 8 + gcc/ada/6vcstrea.adb | 8 +- gcc/ada/6vinterf.ads | 34 +- gcc/ada/7sinmaop.adb | 8 +- gcc/ada/7sintman.adb | 109 +- gcc/ada/7sosinte.adb | 18 +- gcc/ada/7sosprim.adb | 16 +- gcc/ada/7staprop.adb | 234 ++- gcc/ada/7staspri.ads | 8 +- gcc/ada/7stfsetr.adb | 313 +++ gcc/ada/7stpopsp.adb | 37 +- gcc/ada/7straceb.adb | 33 +- gcc/ada/7straces.adb | 73 + gcc/ada/7strafor.adb | 113 ++ gcc/ada/7strafor.ads | 62 + gcc/ada/7stratas.adb | 367 ++++ gcc/ada/9drpc.adb | 2 +- gcc/ada/ChangeLog | 259 +++ gcc/ada/Make-lang.in | 3165 +++++++++++++++++++---------- gcc/ada/Makefile.adalib | 45 +- gcc/ada/Makefile.generic | 409 ++++ gcc/ada/Makefile.in | 1622 ++++++++------- gcc/ada/Makefile.prolog | 47 + gcc/ada/Makefile.rtl | 448 +++++ gcc/ada/a-caldel.adb | 8 +- gcc/ada/a-caldel.ads | 2 +- gcc/ada/a-charac.ads | 3 +- gcc/ada/a-colien.ads | 8 +- gcc/ada/a-comlin.adb | 46 +- gcc/ada/a-diocst.adb | 18 +- gcc/ada/a-diocst.ads | 9 +- gcc/ada/a-direio.adb | 5 +- gcc/ada/a-excach.adb | 71 + gcc/ada/a-except.adb | 2630 +++++++----------------- gcc/ada/a-except.ads | 68 +- gcc/ada/a-excpol.adb | 2 +- gcc/ada/a-exctra.adb | 14 +- gcc/ada/a-exctra.ads | 23 +- gcc/ada/a-exexda.adb | 526 +++++ gcc/ada/a-exexpr.adb | 525 +++++ gcc/ada/a-exextr.adb | 327 +++ gcc/ada/a-exstat.adb | 255 +++ gcc/ada/a-filico.adb | 4 +- gcc/ada/a-interr.adb | 8 +- gcc/ada/a-intsig.adb | 6 +- gcc/ada/a-intsig.ads | 6 +- gcc/ada/a-ngcefu.adb | 11 +- gcc/ada/a-ngcoty.adb | 11 +- gcc/ada/a-ngelfu.adb | 25 +- gcc/ada/a-nudira.adb | 11 +- gcc/ada/a-nudira.ads | 15 +- gcc/ada/a-nuflra.adb | 8 +- gcc/ada/a-nuflra.ads | 10 +- gcc/ada/a-reatim.adb | 9 +- gcc/ada/a-reatim.ads | 8 +- gcc/ada/a-retide.ads | 6 +- gcc/ada/a-sequio.adb | 18 +- gcc/ada/a-siocst.adb | 18 +- gcc/ada/a-siocst.ads | 9 +- gcc/ada/a-ssicst.adb | 18 +- gcc/ada/a-ssicst.ads | 9 +- gcc/ada/a-strbou.adb | 1687 +--------------- gcc/ada/a-strbou.ads | 426 +++- gcc/ada/a-strfix.adb | 9 +- gcc/ada/a-strmap.adb | 4 +- gcc/ada/a-strsea.ads | 2 +- gcc/ada/a-strsup.adb | 1807 +++++++++++++++++ gcc/ada/a-strsup.ads | 473 +++++ gcc/ada/a-strunb.adb | 497 +++-- gcc/ada/a-strunb.ads | 20 +- gcc/ada/a-ststio.adb | 30 +- gcc/ada/a-stunau.adb | 32 +- gcc/ada/a-stunau.ads | 6 +- gcc/ada/a-stwibo.adb | 1728 +--------------- gcc/ada/a-stwibo.ads | 429 +++- gcc/ada/a-stwifi.adb | 7 +- gcc/ada/a-stwima.adb | 4 +- gcc/ada/a-stwisu.adb | 1809 +++++++++++++++++ gcc/ada/a-stwisu.ads | 478 +++++ gcc/ada/a-stwiun.adb | 550 ++--- gcc/ada/a-stwiun.ads | 12 +- gcc/ada/a-tags.adb | 69 +- gcc/ada/a-tags.ads | 22 +- gcc/ada/a-tasatt.adb | 356 ++-- gcc/ada/a-taside.adb | 10 +- gcc/ada/a-teioed.adb | 170 +- gcc/ada/a-textio.adb | 56 +- gcc/ada/a-textio.ads | 9 +- gcc/ada/a-tienau.adb | 42 +- gcc/ada/a-tifiio.adb | 555 +++++- gcc/ada/a-tiflau.adb | 3 +- gcc/ada/a-tiflio.adb | 29 +- gcc/ada/a-tigeau.adb | 9 +- gcc/ada/a-tigeau.ads | 11 +- gcc/ada/a-tiinau.adb | 4 +- gcc/ada/a-timoau.adb | 4 +- gcc/ada/a-tiocst.adb | 18 +- gcc/ada/a-tiocst.ads | 9 +- gcc/ada/a-witeio.adb | 23 +- gcc/ada/a-witeio.ads | 2 +- gcc/ada/a-wtcstr.adb | 18 +- gcc/ada/a-wtcstr.ads | 9 +- gcc/ada/a-wtdeio.adb | 4 +- gcc/ada/a-wtedit.adb | 10 +- gcc/ada/a-wtenau.adb | 8 +- gcc/ada/a-wtflau.adb | 3 +- gcc/ada/a-wtinau.adb | 6 +- gcc/ada/a-wtmoau.adb | 6 +- gcc/ada/ada-tree.def | 3 +- gcc/ada/adafinal.c | 56 - gcc/ada/adaint.c | 648 +++--- gcc/ada/adaint.h | 210 +- gcc/ada/ali-util.adb | 306 +-- gcc/ada/ali-util.ads | 14 +- gcc/ada/ali.adb | 847 +++++--- gcc/ada/ali.ads | 159 +- gcc/ada/atree.adb | 83 +- gcc/ada/atree.ads | 32 +- gcc/ada/bcheck.adb | 253 ++- gcc/ada/binde.adb | 157 +- gcc/ada/bindgen.adb | 1225 ++++++------ gcc/ada/bindusg.adb | 13 +- gcc/ada/bld-io.adb | 273 +++ gcc/ada/bld-io.ads | 73 + gcc/ada/bld.adb | 3538 ++++++++++++++++++++++++++++++++ gcc/ada/bld.ads | 38 + gcc/ada/checks.adb | 1984 +++++++++++++++--- gcc/ada/checks.ads | 155 +- gcc/ada/cio.c | 5 +- gcc/ada/clean.adb | 1444 ++++++++++++++ gcc/ada/clean.ads | 35 + gcc/ada/comperr.adb | 58 +- gcc/ada/comperr.ads | 22 +- gcc/ada/csets.adb | 20 +- gcc/ada/cstand.adb | 59 +- gcc/ada/cstreams.c | 26 +- gcc/ada/ctrl_c.c | 158 ++ gcc/ada/debug.adb | 275 ++- gcc/ada/debug.ads | 70 +- gcc/ada/debug_a.adb | 31 +- gcc/ada/debug_a.ads | 8 +- gcc/ada/decl.c | 866 +++++--- gcc/ada/einfo.adb | 695 ++++--- gcc/ada/einfo.ads | 726 ++++--- gcc/ada/einfo.h | 174 +- gcc/ada/err_vars.ads | 114 ++ gcc/ada/errout.adb | 2181 +++++++------------- gcc/ada/errout.ads | 152 +- gcc/ada/erroutc.adb | 1013 ++++++++++ gcc/ada/erroutc.ads | 398 ++++ gcc/ada/errutil.adb | 744 +++++++ gcc/ada/errutil.ads | 250 +++ gcc/ada/eval_fat.adb | 232 ++- gcc/ada/eval_fat.ads | 33 +- gcc/ada/exp_aggr.adb | 1196 +++++++---- gcc/ada/exp_attr.adb | 584 ++++-- gcc/ada/exp_ch11.adb | 132 +- gcc/ada/exp_ch13.adb | 26 +- gcc/ada/exp_ch2.adb | 258 ++- gcc/ada/exp_ch3.adb | 829 +++++--- gcc/ada/exp_ch3.ads | 10 +- gcc/ada/exp_ch4.adb | 2589 +++++++++++++++++------- gcc/ada/exp_ch5.adb | 574 ++++-- gcc/ada/exp_ch6.adb | 544 +++-- gcc/ada/exp_ch7.adb | 705 +++++-- gcc/ada/exp_ch7.ads | 76 +- gcc/ada/exp_ch8.adb | 19 +- gcc/ada/exp_ch9.adb | 720 ++++--- gcc/ada/exp_code.adb | 8 +- gcc/ada/exp_dbug.adb | 413 +--- gcc/ada/exp_dbug.ads | 180 +- gcc/ada/exp_disp.adb | 118 +- gcc/ada/exp_dist.adb | 621 +++--- gcc/ada/exp_fixd.adb | 69 +- gcc/ada/exp_imgv.adb | 4 +- gcc/ada/exp_intr.adb | 137 +- gcc/ada/exp_pakd.adb | 188 +- gcc/ada/exp_prag.adb | 290 +-- gcc/ada/exp_strm.adb | 225 +-- gcc/ada/exp_strm.ads | 30 +- gcc/ada/exp_tss.adb | 197 +- gcc/ada/exp_tss.ads | 113 +- gcc/ada/exp_util.adb | 1186 ++++++++--- gcc/ada/exp_util.ads | 81 +- gcc/ada/exp_vfpt.adb | 1 - gcc/ada/expander.adb | 432 ++-- gcc/ada/expander.ads | 12 +- gcc/ada/expect.c | 232 ++- gcc/ada/fe.h | 130 +- gcc/ada/final.c | 43 + gcc/ada/fmap.adb | 203 +- gcc/ada/fmap.ads | 22 +- gcc/ada/fname-uf.adb | 22 +- gcc/ada/fname-uf.ads | 5 +- gcc/ada/fname.adb | 15 +- gcc/ada/fname.ads | 9 +- gcc/ada/freeze.adb | 953 +++++++-- gcc/ada/freeze.ads | 12 +- gcc/ada/frontend.adb | 294 +-- gcc/ada/g-arrspl.adb | 309 +++ gcc/ada/g-arrspl.ads | 187 ++ gcc/ada/g-awk.adb | 27 +- gcc/ada/g-awk.ads | 7 +- gcc/ada/g-boubuf.adb | 93 + gcc/ada/g-boubuf.ads | 101 + gcc/ada/g-boumai.ads | 98 + gcc/ada/g-bubsor.adb | 58 + gcc/ada/g-bubsor.ads | 68 + gcc/ada/g-busora.adb | 3 +- gcc/ada/g-busora.ads | 13 +- gcc/ada/g-busorg.adb | 3 +- gcc/ada/g-busorg.ads | 31 +- gcc/ada/g-casuti.adb | 80 +- gcc/ada/g-casuti.ads | 32 +- gcc/ada/g-catiio.adb | 51 +- gcc/ada/g-catiio.ads | 14 +- gcc/ada/g-cgi.adb | 3 +- gcc/ada/g-cgi.ads | 3 +- gcc/ada/g-cgicoo.adb | 5 +- gcc/ada/g-cgicoo.ads | 3 +- gcc/ada/g-cgideb.adb | 3 +- gcc/ada/g-cgideb.ads | 3 +- gcc/ada/g-comlin.adb | 51 +- gcc/ada/g-comlin.ads | 27 +- gcc/ada/g-comver.adb | 69 + gcc/ada/g-comver.ads | 64 + gcc/ada/g-crc32.adb | 3 +- gcc/ada/g-crc32.ads | 3 +- gcc/ada/g-ctrl_c.ads | 67 + gcc/ada/g-debpoo.adb | 1570 ++++++++++++++- gcc/ada/g-debpoo.ads | 272 ++- gcc/ada/g-debuti.adb | 95 +- gcc/ada/g-debuti.ads | 40 +- gcc/ada/g-diopit.adb | 41 +- gcc/ada/g-diopit.ads | 3 +- gcc/ada/g-dirope.adb | 172 +- gcc/ada/g-dirope.ads | 85 +- gcc/ada/g-dynhta.adb | 344 ++++ gcc/ada/g-dynhta.ads | 240 +++ gcc/ada/g-dyntab.adb | 131 +- gcc/ada/g-dyntab.ads | 38 +- gcc/ada/g-eacodu.adb | 51 + gcc/ada/g-enblsp.adb | 115 -- gcc/ada/g-excact.adb | 134 ++ gcc/ada/g-excact.ads | 118 ++ gcc/ada/g-except.ads | 15 +- gcc/ada/g-exctra.adb | 3 +- gcc/ada/g-exctra.ads | 3 +- gcc/ada/g-expect.adb | 142 +- gcc/ada/g-expect.ads | 44 +- gcc/ada/g-heasor.adb | 132 ++ gcc/ada/g-heasor.ads | 73 + gcc/ada/g-hesora.adb | 3 +- gcc/ada/g-hesora.ads | 17 +- gcc/ada/g-hesorg.adb | 21 +- gcc/ada/g-hesorg.ads | 43 +- gcc/ada/g-htable.adb | 336 +--- gcc/ada/g-htable.ads | 200 +- gcc/ada/g-io.adb | 3 +- gcc/ada/g-io.ads | 3 +- gcc/ada/g-io_aux.adb | 3 +- gcc/ada/g-io_aux.ads | 3 +- gcc/ada/g-locfil.adb | 4 +- gcc/ada/g-locfil.ads | 3 +- gcc/ada/g-md5.adb | 3 +- gcc/ada/g-md5.ads | 7 +- gcc/ada/g-memdum.adb | 125 ++ gcc/ada/g-memdum.ads | 56 + gcc/ada/g-os_lib.adb | 783 +++++++- gcc/ada/g-os_lib.ads | 272 ++- gcc/ada/g-pehage.adb | 2400 ++++++++++++++++++++++ gcc/ada/g-pehage.ads | 186 ++ gcc/ada/g-perhas.ads | 67 + gcc/ada/g-regexp.adb | 3 +- gcc/ada/g-regexp.ads | 3 +- gcc/ada/g-regist.adb | 61 +- gcc/ada/g-regist.ads | 25 +- gcc/ada/g-regpat.adb | 563 +++--- gcc/ada/g-regpat.ads | 100 +- gcc/ada/g-semaph.adb | 86 + gcc/ada/g-semaph.ads | 100 + gcc/ada/g-soccon.ads | 201 +- gcc/ada/g-socket.adb | 880 +++++--- gcc/ada/g-socket.ads | 559 ++++-- gcc/ada/g-socthi.adb | 242 ++- gcc/ada/g-socthi.ads | 150 +- gcc/ada/g-soliop.ads | 13 +- gcc/ada/g-souinf.ads | 3 +- gcc/ada/g-speche.adb | 7 +- gcc/ada/g-speche.ads | 3 +- gcc/ada/g-spipat.adb | 45 +- gcc/ada/g-spipat.ads | 22 +- gcc/ada/g-spitbo.adb | 3 +- gcc/ada/g-spitbo.ads | 3 +- gcc/ada/g-sptabo.ads | 3 +- gcc/ada/g-sptain.ads | 3 +- gcc/ada/g-sptavs.ads | 3 +- gcc/ada/g-string.adb | 61 + gcc/ada/g-string.ads | 58 + gcc/ada/g-strspl.ads | 46 + gcc/ada/g-table.adb | 3 +- gcc/ada/g-table.ads | 22 +- gcc/ada/g-tasloc.adb | 3 +- gcc/ada/g-tasloc.ads | 3 +- gcc/ada/g-thread.adb | 90 +- gcc/ada/g-thread.ads | 53 +- gcc/ada/g-traceb.adb | 3 +- gcc/ada/g-traceb.ads | 8 +- gcc/ada/g-trasym.adb | 3 +- gcc/ada/g-trasym.ads | 16 +- gcc/ada/g-wistsp.ads | 46 + gcc/ada/gigi.h | 65 +- gcc/ada/gmem.c | 146 +- gcc/ada/gnat1drv.adb | 199 +- gcc/ada/gnatbind.adb | 205 +- gcc/ada/gnatchop.adb | 5 +- gcc/ada/gnatclean.adb | 42 + gcc/ada/gnatcmd.adb | 4501 ++++++++--------------------------------- gcc/ada/gnatfind.adb | 25 +- gcc/ada/gnatkr.adb | 33 +- gcc/ada/gnatlbr.adb | 2 + gcc/ada/gnatlink.adb | 613 ++++-- gcc/ada/gnatls.adb | 46 +- gcc/ada/gnatmake.adb | 2 +- gcc/ada/gnatmem.adb | 936 +++------ gcc/ada/gnatname.adb | 75 +- gcc/ada/gnatprep.adb | 1529 +------------- gcc/ada/gnatprep.ads | 17 +- gcc/ada/gnatpsta.adb | 1 - gcc/ada/gnatsym.adb | 239 +++ gcc/ada/gnatvsn.adb | 54 +- gcc/ada/gnatvsn.ads | 29 +- gcc/ada/gnatxref.adb | 24 +- gcc/ada/gpr2make.adb | 34 + gcc/ada/gpr2make.ads | 30 + gcc/ada/gprcmd.adb | 423 ++++ gcc/ada/gprep.adb | 439 ++++ gcc/ada/gprep.ads | 34 + gcc/ada/hostparm.ads | 5 +- gcc/ada/i-c.ads | 34 +- gcc/ada/i-cobol.adb | 3 +- gcc/ada/i-cpp.adb | 4 +- gcc/ada/i-cstrea.ads | 2 +- gcc/ada/i-cstrin.adb | 25 +- gcc/ada/i-cstrin.ads | 13 +- gcc/ada/i-pacdec.ads | 3 +- gcc/ada/i-vthrea.adb | 386 ++++ gcc/ada/i-vthrea.ads | 93 + gcc/ada/i-vxwoio.adb | 80 + gcc/ada/i-vxwoio.ads | 228 +++ gcc/ada/i-vxwork.ads | 20 +- gcc/ada/impunit.adb | 46 +- gcc/ada/init.c | 524 +++-- gcc/ada/inline.adb | 200 +- gcc/ada/interfac.ads | 32 +- gcc/ada/io-aux.c | 53 - gcc/ada/itypes.adb | 8 +- gcc/ada/itypes.ads | 4 +- gcc/ada/lang-specs.h | 7 +- gcc/ada/lang.opt | 22 +- gcc/ada/layout.adb | 631 ++++-- gcc/ada/lib-list.adb | 7 +- gcc/ada/lib-load.adb | 108 +- gcc/ada/lib-load.ads | 15 +- gcc/ada/lib-sort.adb | 20 +- gcc/ada/lib-util.adb | 4 +- gcc/ada/lib-writ.adb | 117 +- gcc/ada/lib-writ.ads | 72 +- gcc/ada/lib-xref.adb | 931 +++++++-- gcc/ada/lib-xref.ads | 92 +- gcc/ada/lib.adb | 180 +- gcc/ada/lib.ads | 35 +- gcc/ada/link.c | 9 +- gcc/ada/live.adb | 10 +- gcc/ada/make.adb | 4247 +++++++++++++++++++++++++++------------ gcc/ada/make.ads | 7 +- gcc/ada/makeusg.adb | 32 +- gcc/ada/mdll-fil.adb | 2 +- gcc/ada/mdll-fil.ads | 2 +- gcc/ada/mdll-utl.adb | 62 +- gcc/ada/mdll-utl.ads | 2 +- gcc/ada/mdll.adb | 45 +- gcc/ada/memroot.adb | 286 ++- gcc/ada/memroot.ads | 23 +- gcc/ada/memtrack.adb | 129 +- gcc/ada/misc.c | 220 +- gcc/ada/mkdir.c | 17 +- gcc/ada/mlib-fil.adb | 2 +- gcc/ada/mlib-fil.ads | 2 +- gcc/ada/mlib-prj.adb | 1801 +++++++++++++++-- gcc/ada/mlib-prj.ads | 26 +- gcc/ada/mlib-tgt.adb | 130 +- gcc/ada/mlib-tgt.ads | 109 +- gcc/ada/mlib-utl.adb | 154 +- gcc/ada/mlib-utl.ads | 24 +- gcc/ada/mlib.adb | 228 ++- gcc/ada/mlib.ads | 33 +- gcc/ada/namet.adb | 108 +- gcc/ada/namet.ads | 44 +- gcc/ada/namet.h | 5 +- gcc/ada/nlists.ads | 2 +- gcc/ada/nlists.h | 1 - gcc/ada/nmake.adb | 18 +- gcc/ada/nmake.ads | 15 +- gcc/ada/nmake.adt | 3 +- gcc/ada/opt.adb | 89 +- gcc/ada/opt.ads | 339 +++- gcc/ada/osint-b.adb | 11 +- gcc/ada/osint-c.adb | 42 +- gcc/ada/osint.adb | 403 +++- gcc/ada/osint.ads | 20 +- gcc/ada/par-ch10.adb | 46 +- gcc/ada/par-ch11.adb | 4 +- gcc/ada/par-ch2.adb | 17 +- gcc/ada/par-ch3.adb | 49 +- gcc/ada/par-ch4.adb | 24 +- gcc/ada/par-ch5.adb | 128 +- gcc/ada/par-ch6.adb | 16 +- gcc/ada/par-ch9.adb | 13 +- gcc/ada/par-endh.adb | 71 +- gcc/ada/par-labl.adb | 9 +- gcc/ada/par-load.adb | 4 +- gcc/ada/par-prag.adb | 655 +++--- gcc/ada/par-sync.adb | 44 +- gcc/ada/par-tchk.adb | 53 +- gcc/ada/par-util.adb | 27 +- gcc/ada/par.adb | 24 +- gcc/ada/prep.adb | 1446 ++++++++++++++ gcc/ada/prep.ads | 130 ++ gcc/ada/prepcomp.adb | 783 ++++++++ gcc/ada/prepcomp.ads | 67 + gcc/ada/prj-attr.adb | 72 +- gcc/ada/prj-attr.ads | 14 +- gcc/ada/prj-com.adb | 2 +- gcc/ada/prj-com.ads | 14 +- gcc/ada/prj-dect.adb | 532 +++-- gcc/ada/prj-dect.ads | 2 +- gcc/ada/prj-env.adb | 1061 ++++++---- gcc/ada/prj-env.ads | 48 +- gcc/ada/prj-err.adb | 64 + gcc/ada/prj-err.ads | 100 + gcc/ada/prj-ext.adb | 65 +- gcc/ada/prj-ext.ads | 14 +- gcc/ada/prj-makr.adb | 765 ++++--- gcc/ada/prj-makr.ads | 10 +- gcc/ada/prj-nmsc.adb | 2919 ++++++++++++++++++--------- gcc/ada/prj-nmsc.ads | 6 +- gcc/ada/prj-pars.adb | 20 +- gcc/ada/prj-pars.ads | 12 +- gcc/ada/prj-part.adb | 961 ++++++--- gcc/ada/prj-part.ads | 20 +- gcc/ada/prj-pp.adb | 97 +- gcc/ada/prj-pp.ads | 12 +- gcc/ada/prj-proc.adb | 1088 +++++++--- gcc/ada/prj-proc.ads | 9 +- gcc/ada/prj-strt.adb | 778 +++++--- gcc/ada/prj-strt.ads | 4 +- gcc/ada/prj-tree.adb | 270 ++- gcc/ada/prj-tree.ads | 186 +- gcc/ada/prj-util.adb | 256 ++- gcc/ada/prj-util.ads | 46 +- gcc/ada/prj.adb | 218 +- gcc/ada/prj.ads | 204 +- gcc/ada/raise.c | 1282 ++++++++---- gcc/ada/raise.h | 10 +- gcc/ada/repinfo.adb | 430 +++- gcc/ada/repinfo.h | 7 +- gcc/ada/restrict.adb | 215 +- gcc/ada/restrict.ads | 88 +- gcc/ada/rident.ads | 130 +- gcc/ada/rtsfind.adb | 494 +++-- gcc/ada/rtsfind.ads | 336 ++-- gcc/ada/s-addima.ads | 5 +- gcc/ada/s-arit64.adb | 2 +- gcc/ada/s-assert.adb | 2 +- gcc/ada/s-assert.ads | 7 +- gcc/ada/s-atacco.adb | 31 +- gcc/ada/s-atacco.ads | 17 +- gcc/ada/s-auxdec.adb | 4 +- gcc/ada/s-auxdec.ads | 42 +- gcc/ada/s-bitops.adb | 10 +- gcc/ada/s-boarop.ads | 65 + gcc/ada/s-carsi8.adb | 141 ++ gcc/ada/s-carsi8.ads | 66 + gcc/ada/s-carun8.adb | 140 ++ gcc/ada/s-carun8.ads | 66 + gcc/ada/s-casi16.adb | 137 ++ gcc/ada/s-casi16.ads | 56 + gcc/ada/s-casi32.adb | 120 ++ gcc/ada/s-casi32.ads | 55 + gcc/ada/s-casi64.adb | 120 ++ gcc/ada/s-casi64.ads | 55 + gcc/ada/s-casuti.adb | 105 + gcc/ada/s-casuti.ads | 66 + gcc/ada/s-caun16.adb | 137 ++ gcc/ada/s-caun16.ads | 56 + gcc/ada/s-caun32.adb | 120 ++ gcc/ada/s-caun32.ads | 55 + gcc/ada/s-caun64.adb | 119 ++ gcc/ada/s-caun64.ads | 55 + gcc/ada/s-crc32.adb | 7 +- gcc/ada/s-crc32.ads | 3 +- gcc/ada/s-direio.adb | 20 +- gcc/ada/s-errrep.adb | 8 +- gcc/ada/s-errrep.ads | 8 +- gcc/ada/s-exctab.adb | 67 +- gcc/ada/s-exctab.ads | 34 +- gcc/ada/s-exnflt.ads | 44 - gcc/ada/s-exngen.adb | 152 -- gcc/ada/s-exngen.ads | 64 - gcc/ada/s-exnint.adb | 76 + gcc/ada/s-exnint.ads | 10 +- gcc/ada/s-exnlfl.ads | 44 - gcc/ada/s-exnlin.ads | 44 - gcc/ada/s-exnllf.adb | 99 + gcc/ada/s-exnllf.ads | 10 +- gcc/ada/s-exnlli.adb | 76 + gcc/ada/s-exnlli.ads | 10 +- gcc/ada/s-exnsfl.ads | 44 - gcc/ada/s-exnsin.ads | 44 - gcc/ada/s-exnssi.ads | 44 - gcc/ada/s-expflt.ads | 43 - gcc/ada/s-expgen.adb | 181 -- gcc/ada/s-expgen.ads | 64 - gcc/ada/s-expint.adb | 85 + gcc/ada/s-expint.ads | 9 +- gcc/ada/s-explfl.ads | 44 - gcc/ada/s-explin.ads | 44 - gcc/ada/s-expllf.ads | 44 - gcc/ada/s-explli.adb | 85 + gcc/ada/s-explli.ads | 10 +- gcc/ada/s-expsfl.ads | 44 - gcc/ada/s-expsin.ads | 44 - gcc/ada/s-expssi.ads | 44 - gcc/ada/s-expuns.ads | 4 +- gcc/ada/s-fatflt.ads | 4 +- gcc/ada/s-fatgen.adb | 37 +- gcc/ada/s-fatgen.ads | 22 +- gcc/ada/s-fatlfl.ads | 4 +- gcc/ada/s-fatllf.ads | 4 +- gcc/ada/s-fatsfl.ads | 4 +- gcc/ada/s-fileio.adb | 97 +- gcc/ada/s-fileio.ads | 4 +- gcc/ada/s-finimp.adb | 191 +- gcc/ada/s-finimp.ads | 42 +- gcc/ada/s-finroo.adb | 4 +- gcc/ada/s-finroo.ads | 3 +- gcc/ada/s-geveop.adb | 123 ++ gcc/ada/s-geveop.ads | 66 + gcc/ada/s-gloloc.adb | 38 +- gcc/ada/s-gloloc.ads | 16 +- gcc/ada/s-hibaen.ads | 101 + gcc/ada/s-htable.adb | 362 ++++ gcc/ada/s-htable.ads | 198 ++ gcc/ada/s-imgdec.adb | 2 +- gcc/ada/s-imgenu.adb | 14 +- gcc/ada/s-imgrea.adb | 98 +- gcc/ada/s-imgwch.adb | 4 +- gcc/ada/s-inmaop.ads | 2 +- gcc/ada/s-interr.adb | 73 +- gcc/ada/s-interr.ads | 10 +- gcc/ada/s-intman.ads | 98 +- gcc/ada/s-maccod.ads | 2 +- gcc/ada/s-mastop.adb | 2 +- gcc/ada/s-mastop.ads | 2 +- gcc/ada/s-memcop.ads | 76 + gcc/ada/s-memory.adb | 10 +- gcc/ada/s-memory.ads | 60 +- gcc/ada/s-osprim.ads | 12 +- gcc/ada/s-parame.ads | 19 +- gcc/ada/s-parint.ads | 5 +- gcc/ada/s-pooloc.adb | 13 +- gcc/ada/s-pooloc.ads | 2 - gcc/ada/s-poosiz.adb | 53 +- gcc/ada/s-proinf.ads | 7 +- gcc/ada/s-purexc.ads | 77 + gcc/ada/s-rident.ads | 156 ++ gcc/ada/s-scaval.adb | 266 +++ gcc/ada/s-scaval.ads | 61 +- gcc/ada/s-secsta.adb | 5 +- gcc/ada/s-secsta.ads | 11 +- gcc/ada/s-sequio.adb | 28 +- gcc/ada/s-shasto.adb | 94 +- gcc/ada/s-shasto.ads | 8 +- gcc/ada/s-soflin.ads | 7 +- gcc/ada/s-stache.adb | 17 +- gcc/ada/s-stache.ads | 7 +- gcc/ada/s-stalib.adb | 19 +- gcc/ada/s-stalib.ads | 32 +- gcc/ada/s-stoele.ads | 55 +- gcc/ada/s-stopoo.adb | 65 + gcc/ada/s-stopoo.ads | 21 +- gcc/ada/s-stratt.adb | 9 +- gcc/ada/s-stratt.ads | 26 +- gcc/ada/s-strcom.adb | 140 ++ gcc/ada/s-strcom.ads | 61 + gcc/ada/s-strops.adb | 22 +- gcc/ada/s-strops.ads | 6 +- gcc/ada/s-strxdr.adb | 1811 +++++++++++++++++ gcc/ada/s-taasde.adb | 10 +- gcc/ada/s-taasde.ads | 5 +- gcc/ada/s-tadeca.adb | 5 +- gcc/ada/s-tadeca.ads | 5 +- gcc/ada/s-tadert.adb | 5 +- gcc/ada/s-tadert.ads | 5 +- gcc/ada/s-taenca.adb | 69 +- gcc/ada/s-taenca.ads | 4 +- gcc/ada/s-taprob.adb | 8 +- gcc/ada/s-taprob.ads | 28 +- gcc/ada/s-taprop.ads | 27 +- gcc/ada/s-tarest.adb | 22 +- gcc/ada/s-tarest.ads | 42 +- gcc/ada/s-tasdeb.adb | 563 +----- gcc/ada/s-tasdeb.ads | 173 +- gcc/ada/s-tasinf.adb | 2 +- gcc/ada/s-tasinf.ads | 22 +- gcc/ada/s-tasini.adb | 70 +- gcc/ada/s-tasini.ads | 2 +- gcc/ada/s-taskin.adb | 21 +- gcc/ada/s-taskin.ads | 55 +- gcc/ada/s-tasque.adb | 21 +- gcc/ada/s-tasque.ads | 4 +- gcc/ada/s-tasren.adb | 129 +- gcc/ada/s-tasren.ads | 2 +- gcc/ada/s-tasres.ads | 2 +- gcc/ada/s-tassta.adb | 304 +-- gcc/ada/s-tassta.ads | 51 +- gcc/ada/s-tasuti.adb | 29 +- gcc/ada/s-tasuti.ads | 4 +- gcc/ada/s-tataat.adb | 23 +- gcc/ada/s-tataat.ads | 12 +- gcc/ada/s-thread.adb | 101 + gcc/ada/s-thread.ads | 93 + gcc/ada/s-tpae65.adb | 87 + gcc/ada/s-tpae65.ads | 54 + gcc/ada/s-tpinop.adb | 2 +- gcc/ada/s-tpinop.ads | 2 +- gcc/ada/s-tpoben.adb | 4 +- gcc/ada/s-tpoben.ads | 8 +- gcc/ada/s-tpobop.adb | 16 +- gcc/ada/s-tpobop.ads | 2 +- gcc/ada/s-tporft.adb | 104 + gcc/ada/s-tposen.adb | 11 +- gcc/ada/s-tposen.ads | 37 +- gcc/ada/s-traceb.adb | 32 +- gcc/ada/s-traceb.ads | 11 +- gcc/ada/s-traent.adb | 59 + gcc/ada/s-traent.ads | 62 + gcc/ada/s-unstyp.ads | 5 +- gcc/ada/s-vaflop.ads | 2 +- gcc/ada/s-valrea.adb | 78 +- gcc/ada/s-valuti.adb | 4 +- gcc/ada/s-veboop.adb | 121 ++ gcc/ada/s-veboop.ads | 68 + gcc/ada/s-vector.ads | 51 + gcc/ada/s-vercon.adb | 5 +- gcc/ada/s-vmexta.adb | 20 +- gcc/ada/s-wchcnv.ads | 5 +- gcc/ada/s-wchcon.ads | 5 +- gcc/ada/s-widcha.adb | 4 +- gcc/ada/s-wwdcha.adb | 4 +- gcc/ada/s-wwdwch.adb | 5 +- gcc/ada/scans.ads | 32 +- gcc/ada/scn-nlit.adb | 369 ---- gcc/ada/scn-slit.adb | 371 ---- gcc/ada/scn.adb | 1359 +------------ gcc/ada/scn.ads | 48 +- gcc/ada/scng.adb | 2175 ++++++++++++++++++++ gcc/ada/scng.ads | 102 + gcc/ada/sem.adb | 330 ++- gcc/ada/sem.ads | 233 ++- gcc/ada/sem_aggr.adb | 178 +- gcc/ada/sem_attr.adb | 1160 +++++++---- gcc/ada/sem_attr.ads | 11 +- gcc/ada/sem_case.adb | 275 ++- gcc/ada/sem_case.ads | 20 +- gcc/ada/sem_cat.adb | 187 +- gcc/ada/sem_cat.ads | 16 +- gcc/ada/sem_ch10.adb | 946 ++++++++- gcc/ada/sem_ch11.adb | 129 +- gcc/ada/sem_ch12.adb | 1175 ++++++++--- gcc/ada/sem_ch12.ads | 27 +- gcc/ada/sem_ch13.adb | 565 +++--- gcc/ada/sem_ch13.ads | 13 +- gcc/ada/sem_ch3.adb | 1707 +++++++++------- gcc/ada/sem_ch3.ads | 37 +- gcc/ada/sem_ch4.adb | 421 ++-- gcc/ada/sem_ch5.adb | 446 ++++- gcc/ada/sem_ch5.ads | 2 +- gcc/ada/sem_ch6.adb | 962 ++++++--- gcc/ada/sem_ch6.ads | 39 +- gcc/ada/sem_ch7.adb | 492 +++-- gcc/ada/sem_ch7.ads | 12 +- gcc/ada/sem_ch8.adb | 715 ++++--- gcc/ada/sem_ch8.ads | 47 +- gcc/ada/sem_ch9.adb | 298 ++- gcc/ada/sem_disp.adb | 97 +- gcc/ada/sem_disp.ads | 4 +- gcc/ada/sem_dist.adb | 30 +- gcc/ada/sem_elab.adb | 220 +- gcc/ada/sem_eval.adb | 649 +++++- gcc/ada/sem_eval.ads | 67 +- gcc/ada/sem_intr.adb | 9 +- gcc/ada/sem_maps.adb | 4 +- gcc/ada/sem_mech.adb | 25 +- gcc/ada/sem_prag.adb | 1889 ++++++++++++++---- gcc/ada/sem_prag.ads | 20 +- gcc/ada/sem_res.adb | 1013 +++++++--- gcc/ada/sem_res.ads | 17 +- gcc/ada/sem_type.adb | 512 ++++- gcc/ada/sem_type.ads | 54 +- gcc/ada/sem_util.adb | 1214 +++++++++-- gcc/ada/sem_util.ads | 189 +- gcc/ada/sem_warn.adb | 681 ++++++- gcc/ada/sfn_scan.adb | 26 +- gcc/ada/sinfo.adb | 210 +- gcc/ada/sinfo.ads | 251 ++- gcc/ada/sinfo.h | 38 +- gcc/ada/sinput-c.adb | 200 ++ gcc/ada/sinput-c.ads | 39 + gcc/ada/sinput-d.adb | 18 +- gcc/ada/sinput-l.adb | 311 ++- gcc/ada/sinput-l.ads | 26 +- gcc/ada/sinput-p.adb | 183 +- gcc/ada/sinput-p.ads | 11 +- gcc/ada/sinput.adb | 57 +- gcc/ada/sinput.ads | 138 +- gcc/ada/snames.adb | 83 +- gcc/ada/snames.ads | 1263 ++++++------ gcc/ada/snames.h | 409 ++-- gcc/ada/socket.c | 181 ++ gcc/ada/sprint.adb | 60 +- gcc/ada/stringt.adb | 8 +- gcc/ada/stringt.ads | 3 +- gcc/ada/stringt.h | 1 - gcc/ada/style.adb | 854 -------- gcc/ada/style.ads | 117 +- gcc/ada/styleg-c.adb | 225 +++ gcc/ada/styleg-c.ads | 54 + gcc/ada/styleg.adb | 784 ++++++++ gcc/ada/styleg.ads | 159 ++ gcc/ada/stylesw.adb | 15 +- gcc/ada/stylesw.ads | 15 +- gcc/ada/switch-b.adb | 48 +- gcc/ada/switch-c.adb | 380 +++- gcc/ada/switch-m.adb | 127 +- gcc/ada/switch.adb | 10 +- gcc/ada/switch.ads | 4 +- gcc/ada/symbols.adb | 79 + gcc/ada/symbols.ads | 84 + gcc/ada/sysdep.c | 75 +- gcc/ada/system.ads | 22 +- gcc/ada/table.adb | 54 +- gcc/ada/table.ads | 17 +- gcc/ada/targparm.adb | 533 +++-- gcc/ada/targparm.ads | 397 +++- gcc/ada/targtyps.c | 3 +- gcc/ada/tb-alvms.c | 263 +++ gcc/ada/tb-alvxw.c | 965 +++++++++ gcc/ada/tbuild.adb | 30 +- gcc/ada/tbuild.ads | 18 +- gcc/ada/tempdir.adb | 123 ++ gcc/ada/tempdir.ads | 47 + gcc/ada/tracebak.c | 1225 ++---------- gcc/ada/trans.c | 1064 +++++----- gcc/ada/tree_io.adb | 3 + gcc/ada/treepr.adb | 12 +- gcc/ada/treeprs.ads | 457 +++-- gcc/ada/treeprs.adt | 3 +- gcc/ada/ttypes.ads | 6 +- gcc/ada/types.ads | 71 +- gcc/ada/types.h | 17 +- gcc/ada/uintp.adb | 129 +- gcc/ada/uintp.ads | 10 +- gcc/ada/uintp.h | 11 +- gcc/ada/uname.adb | 6 +- gcc/ada/urealp.adb | 70 +- gcc/ada/urealp.ads | 14 +- gcc/ada/urealp.h | 16 +- gcc/ada/usage.adb | 100 +- gcc/ada/utils.c | 405 ++-- gcc/ada/utils2.c | 157 +- gcc/ada/validsw.adb | 12 +- gcc/ada/validsw.ads | 16 +- gcc/ada/vms_conv.adb | 1998 +++++++++++++++++++ gcc/ada/vms_conv.ads | 296 +++ gcc/ada/vms_data.ads | 4991 ++++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/vxaddr2line.adb | 456 +++++ gcc/ada/widechar.adb | 3 +- gcc/ada/xeinfo.adb | 13 +- gcc/ada/xnmake.adb | 7 +- gcc/ada/xr_tabls.adb | 1702 +++++++++------- gcc/ada/xr_tabls.ads | 258 +-- gcc/ada/xref_lib.adb | 1026 +++++----- gcc/ada/xref_lib.ads | 75 +- gcc/ada/xsnames.adb | 9 +- gcc/ada/xtreeprs.adb | 2 +- 1005 files changed, 136347 insertions(+), 56564 deletions(-) create mode 100644 gcc/ada/3psoccon.ads create mode 100644 gcc/ada/3veacodu.adb create mode 100644 gcc/ada/3vexpect.adb create mode 100644 gcc/ada/3vsoccon.ads create mode 100644 gcc/ada/3vsocthi.adb create mode 100644 gcc/ada/3vsocthi.ads create mode 100644 gcc/ada/3vtrasym.adb create mode 100644 gcc/ada/3zsoccon.ads create mode 100644 gcc/ada/3zsocthi.adb create mode 100644 gcc/ada/3zsocthi.ads delete mode 100644 gcc/ada/4dintnam.ads delete mode 100644 gcc/ada/4mintnam.ads delete mode 100644 gcc/ada/4uintnam.ads create mode 100644 gcc/ada/50system.ads create mode 100644 gcc/ada/51system.ads delete mode 100644 gcc/ada/52system.ads create mode 100644 gcc/ada/55system.ads create mode 100644 gcc/ada/56osinte.adb create mode 100644 gcc/ada/56osinte.ads create mode 100644 gcc/ada/56taprop.adb create mode 100644 gcc/ada/56taspri.ads create mode 100644 gcc/ada/56tpopsp.adb create mode 100644 gcc/ada/57system.ads create mode 100644 gcc/ada/58system.ads create mode 100644 gcc/ada/59system.ads create mode 100644 gcc/ada/5aml-tgt.adb create mode 100644 gcc/ada/5bml-tgt.adb create mode 100644 gcc/ada/5csystem.ads delete mode 100644 gcc/ada/5dosinte.ads create mode 100644 gcc/ada/5dsystem.ads delete mode 100644 gcc/ada/5etpopse.adb create mode 100644 gcc/ada/5fosinte.adb create mode 100644 gcc/ada/5gml-tgt.adb create mode 100644 gcc/ada/5hml-tgt.adb create mode 100644 gcc/ada/5isystem.ads create mode 100644 gcc/ada/5lparame.adb delete mode 100644 gcc/ada/5mosinte.ads create mode 100644 gcc/ada/5msystem.ads create mode 100644 gcc/ada/5psystem.ads delete mode 100644 gcc/ada/5qosinte.adb delete mode 100644 gcc/ada/5qosinte.ads delete mode 100644 gcc/ada/5qstache.adb delete mode 100644 gcc/ada/5qtaprop.adb delete mode 100644 gcc/ada/5qtaspri.ads create mode 100644 gcc/ada/5sml-tgt.adb create mode 100644 gcc/ada/5sosprim.adb delete mode 100644 gcc/ada/5stpopse.adb create mode 100644 gcc/ada/5stpopsp.adb create mode 100644 gcc/ada/5tsystem.ads delete mode 100644 gcc/ada/5uintman.adb delete mode 100644 gcc/ada/5uosinte.ads create mode 100644 gcc/ada/5usystem.ads create mode 100644 gcc/ada/5vml-tgt.adb create mode 100644 gcc/ada/5vsymbol.adb create mode 100644 gcc/ada/5vtraent.adb create mode 100644 gcc/ada/5vtraent.ads create mode 100644 gcc/ada/5wml-tgt.adb create mode 100644 gcc/ada/5xparame.ads create mode 100644 gcc/ada/5xsystem.ads create mode 100644 gcc/ada/5xvxwork.ads create mode 100644 gcc/ada/5yparame.ads create mode 100644 gcc/ada/5ytiitho.adb create mode 100644 gcc/ada/5zinit.adb create mode 100644 gcc/ada/5zml-tgt.adb create mode 100644 gcc/ada/5zparame.ads create mode 100644 gcc/ada/5ztaspri.ads create mode 100644 gcc/ada/5ztfsetr.adb create mode 100644 gcc/ada/5zthrini.adb create mode 100644 gcc/ada/5ztiitho.adb create mode 100644 gcc/ada/5ztpopsp.adb create mode 100644 gcc/ada/7stfsetr.adb create mode 100644 gcc/ada/7straces.adb create mode 100644 gcc/ada/7strafor.adb create mode 100644 gcc/ada/7strafor.ads create mode 100644 gcc/ada/7stratas.adb create mode 100644 gcc/ada/Makefile.generic create mode 100644 gcc/ada/Makefile.prolog create mode 100644 gcc/ada/Makefile.rtl create mode 100644 gcc/ada/a-excach.adb create mode 100644 gcc/ada/a-exexda.adb create mode 100644 gcc/ada/a-exexpr.adb create mode 100644 gcc/ada/a-exextr.adb create mode 100644 gcc/ada/a-exstat.adb create mode 100644 gcc/ada/a-strsup.adb create mode 100644 gcc/ada/a-strsup.ads create mode 100644 gcc/ada/a-stwisu.adb create mode 100644 gcc/ada/a-stwisu.ads delete mode 100644 gcc/ada/adafinal.c create mode 100644 gcc/ada/bld-io.adb create mode 100644 gcc/ada/bld-io.ads create mode 100644 gcc/ada/bld.adb create mode 100644 gcc/ada/bld.ads create mode 100644 gcc/ada/clean.adb create mode 100644 gcc/ada/clean.ads create mode 100644 gcc/ada/ctrl_c.c create mode 100644 gcc/ada/err_vars.ads create mode 100644 gcc/ada/erroutc.adb create mode 100644 gcc/ada/erroutc.ads create mode 100644 gcc/ada/errutil.adb create mode 100644 gcc/ada/errutil.ads create mode 100644 gcc/ada/final.c create mode 100644 gcc/ada/g-arrspl.adb create mode 100644 gcc/ada/g-arrspl.ads create mode 100644 gcc/ada/g-boubuf.adb create mode 100644 gcc/ada/g-boubuf.ads create mode 100644 gcc/ada/g-boumai.ads create mode 100644 gcc/ada/g-bubsor.adb create mode 100644 gcc/ada/g-bubsor.ads create mode 100644 gcc/ada/g-comver.adb create mode 100644 gcc/ada/g-comver.ads create mode 100644 gcc/ada/g-ctrl_c.ads create mode 100644 gcc/ada/g-dynhta.adb create mode 100644 gcc/ada/g-dynhta.ads create mode 100644 gcc/ada/g-eacodu.adb delete mode 100644 gcc/ada/g-enblsp.adb create mode 100644 gcc/ada/g-excact.adb create mode 100644 gcc/ada/g-excact.ads create mode 100644 gcc/ada/g-heasor.adb create mode 100644 gcc/ada/g-heasor.ads create mode 100644 gcc/ada/g-memdum.adb create mode 100644 gcc/ada/g-memdum.ads create mode 100644 gcc/ada/g-pehage.adb create mode 100644 gcc/ada/g-pehage.ads create mode 100644 gcc/ada/g-perhas.ads create mode 100644 gcc/ada/g-semaph.adb create mode 100644 gcc/ada/g-semaph.ads create mode 100644 gcc/ada/g-string.adb create mode 100644 gcc/ada/g-string.ads create mode 100644 gcc/ada/g-strspl.ads create mode 100644 gcc/ada/g-wistsp.ads create mode 100644 gcc/ada/gnatclean.adb create mode 100644 gcc/ada/gnatsym.adb create mode 100644 gcc/ada/gpr2make.adb create mode 100644 gcc/ada/gpr2make.ads create mode 100644 gcc/ada/gprcmd.adb create mode 100644 gcc/ada/gprep.adb create mode 100644 gcc/ada/gprep.ads create mode 100644 gcc/ada/i-vthrea.adb create mode 100644 gcc/ada/i-vthrea.ads create mode 100644 gcc/ada/i-vxwoio.adb create mode 100644 gcc/ada/i-vxwoio.ads delete mode 100644 gcc/ada/io-aux.c create mode 100644 gcc/ada/prep.adb create mode 100644 gcc/ada/prep.ads create mode 100644 gcc/ada/prepcomp.adb create mode 100644 gcc/ada/prepcomp.ads create mode 100644 gcc/ada/prj-err.adb create mode 100644 gcc/ada/prj-err.ads create mode 100644 gcc/ada/s-boarop.ads create mode 100644 gcc/ada/s-carsi8.adb create mode 100644 gcc/ada/s-carsi8.ads create mode 100644 gcc/ada/s-carun8.adb create mode 100644 gcc/ada/s-carun8.ads create mode 100644 gcc/ada/s-casi16.adb create mode 100644 gcc/ada/s-casi16.ads create mode 100644 gcc/ada/s-casi32.adb create mode 100644 gcc/ada/s-casi32.ads create mode 100644 gcc/ada/s-casi64.adb create mode 100644 gcc/ada/s-casi64.ads create mode 100644 gcc/ada/s-casuti.adb create mode 100644 gcc/ada/s-casuti.ads create mode 100644 gcc/ada/s-caun16.adb create mode 100644 gcc/ada/s-caun16.ads create mode 100644 gcc/ada/s-caun32.adb create mode 100644 gcc/ada/s-caun32.ads create mode 100644 gcc/ada/s-caun64.adb create mode 100644 gcc/ada/s-caun64.ads delete mode 100644 gcc/ada/s-exnflt.ads delete mode 100644 gcc/ada/s-exngen.adb delete mode 100644 gcc/ada/s-exngen.ads create mode 100644 gcc/ada/s-exnint.adb delete mode 100644 gcc/ada/s-exnlfl.ads delete mode 100644 gcc/ada/s-exnlin.ads create mode 100644 gcc/ada/s-exnllf.adb create mode 100644 gcc/ada/s-exnlli.adb delete mode 100644 gcc/ada/s-exnsfl.ads delete mode 100644 gcc/ada/s-exnsin.ads delete mode 100644 gcc/ada/s-exnssi.ads delete mode 100644 gcc/ada/s-expflt.ads delete mode 100644 gcc/ada/s-expgen.adb delete mode 100644 gcc/ada/s-expgen.ads create mode 100644 gcc/ada/s-expint.adb delete mode 100644 gcc/ada/s-explfl.ads delete mode 100644 gcc/ada/s-explin.ads delete mode 100644 gcc/ada/s-expllf.ads create mode 100644 gcc/ada/s-explli.adb delete mode 100644 gcc/ada/s-expsfl.ads delete mode 100644 gcc/ada/s-expsin.ads delete mode 100644 gcc/ada/s-expssi.ads create mode 100644 gcc/ada/s-geveop.adb create mode 100644 gcc/ada/s-geveop.ads create mode 100644 gcc/ada/s-hibaen.ads create mode 100644 gcc/ada/s-htable.adb create mode 100644 gcc/ada/s-htable.ads create mode 100644 gcc/ada/s-memcop.ads create mode 100644 gcc/ada/s-purexc.ads create mode 100644 gcc/ada/s-rident.ads create mode 100644 gcc/ada/s-scaval.adb create mode 100644 gcc/ada/s-stopoo.adb create mode 100644 gcc/ada/s-strcom.adb create mode 100644 gcc/ada/s-strcom.ads create mode 100644 gcc/ada/s-strxdr.adb create mode 100644 gcc/ada/s-thread.adb create mode 100644 gcc/ada/s-thread.ads create mode 100644 gcc/ada/s-tpae65.adb create mode 100644 gcc/ada/s-tpae65.ads create mode 100644 gcc/ada/s-tporft.adb create mode 100644 gcc/ada/s-traent.adb create mode 100644 gcc/ada/s-traent.ads create mode 100644 gcc/ada/s-veboop.adb create mode 100644 gcc/ada/s-veboop.ads create mode 100644 gcc/ada/s-vector.ads delete mode 100644 gcc/ada/scn-nlit.adb delete mode 100644 gcc/ada/scn-slit.adb create mode 100644 gcc/ada/scng.adb create mode 100644 gcc/ada/scng.ads create mode 100644 gcc/ada/sinput-c.adb create mode 100644 gcc/ada/sinput-c.ads create mode 100644 gcc/ada/socket.c delete mode 100644 gcc/ada/style.adb create mode 100644 gcc/ada/styleg-c.adb create mode 100644 gcc/ada/styleg-c.ads create mode 100644 gcc/ada/styleg.adb create mode 100644 gcc/ada/styleg.ads create mode 100644 gcc/ada/symbols.adb create mode 100644 gcc/ada/symbols.ads create mode 100644 gcc/ada/tb-alvms.c create mode 100644 gcc/ada/tb-alvxw.c create mode 100644 gcc/ada/tempdir.adb create mode 100644 gcc/ada/tempdir.ads create mode 100644 gcc/ada/vms_conv.adb create mode 100644 gcc/ada/vms_conv.ads create mode 100644 gcc/ada/vms_data.ads create mode 100644 gcc/ada/vxaddr2line.adb (limited to 'gcc') 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=, 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/51system.ads b/gcc/ada/51system.ads new file mode 100644 index 00000000000..01404ee32aa --- /dev/null +++ b/gcc/ada/51system.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (SCO UnixWare 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/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/52system.ads b/gcc/ada/52system.ads deleted file mode 100644 index 63485e177ee..00000000000 --- a/gcc/ada/52system.ads +++ /dev/null @@ -1,138 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (LynxOS PPC/x86 Version) --- -- --- 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 -- --- 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; - - -- 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 := 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; - Denorm : 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; - 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; - -end System; 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/56osinte.ads b/gcc/ada/56osinte.ads new file mode 100644 index 00000000000..c6bcbeb9ad4 --- /dev/null +++ b/gcc/ada/56osinte.ads @@ -0,0 +1,584 @@ +------------------------------------------------------------------------------ +-- -- +-- 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) 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- -- +-- 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. + +-- 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 ("-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; + 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 := 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) + 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, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, SIGTHREADKILL); + Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP, SIGPRIO); + + 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 := 0; + SIG_UNBLOCK : constant := 1; + 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 := True; + -- Indicates whether time slicing is supported + + 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 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); + + function To_Timeval (D : Duration) return struct_timeval; + pragma Inline (To_Timeval); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 16#200000#; + SCHED_RR : constant := 16#100000#; + SCHED_OTHER : constant := 16#400000#; + + ------------- + -- 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; + 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; + PTHREAD_CREATE_JOINABLE : constant := 0; + + ----------- + -- Stack -- + ----------- + + Stack_Base_Available : constant Boolean := False; + -- 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. + -- 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 := 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_READ; + 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; + -- This is a dummy procedure to share some GNULLI files + + --------------------------- + -- POSIX.1c Section 3 -- + --------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Inline (sigwait); + -- LynxOS has non standard 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, "pthread_sigmask"); + -- The behavior of pthread_sigmask on LynxOS requires + -- further investigation. + + ---------------------------- + -- 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; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_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; + 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; + pragma Import (C, pthread_cond_timedwait, "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_INHERIT : constant := 1; + PTHREAD_PRIO_PROTECT : constant := 2; + + 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; + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import (C, pthread_attr_setinheritsched); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy); + + function sched_yield return int; + pragma Import (C, sched_yield, "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; + pragma Import (C, 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, "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 st_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, st_setspecific, "st_setspecific"); + + 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 st_keycreate + (destructor : destructor_pointer; + key : access pthread_key_t) return int; + pragma Import (C, st_keycreate, "st_keycreate"); + +private + + type sigset_t is record + X1, X2 : long; + end record; + pragma Convention (C, sigset_t); + + type pid_t is new long; + + 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 unsigned_char; + CLOCK_REALTIME : constant clockid_t := 0; + + type struct_timeval is record + 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 + 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 + cv_magic : unsigned; + cv_pshared : unsigned; + end record; + pragma Convention (C, pthread_condattr_t); + + type pthread_mutexattr_t is record + m_flags : unsigned; + m_prio_c : int; + m_pshared : int; + end record; + pragma Convention (C, pthread_mutexattr_t); + + type tid_t is new short; + type pthread_t is new tid_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 + 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 + 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); + + type pthread_key_t is new int; + +end System.OS_Interface; 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/56taspri.ads b/gcc/ada/56taspri.ads new file mode 100644 index 00000000000..bf079fd34a3 --- /dev/null +++ b/gcc/ada/56taspri.ads @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- 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) 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- -- +-- 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, 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; + -- 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 Lock is record + Mutex : aliased System.OS_Interface.pthread_mutex_t; + Ceiling : System.Any_Priority; + Saved_Priority : System.Any_Priority; + end record; + + type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + + type Private_Data is record + Thread : aliased System.OS_Interface.pthread_t; + pragma Atomic (Thread); + -- Thread field may be updated by two different threads of control. + -- (See, Enter_Task and Create_Task in s-taprop.adb). + -- They put the same value (thr_self value). We do not want to + -- use lock on those operations and the only thing we have to + -- make sure is that they are updated in atomic fashion. + + 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; + +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/5etpopse.adb b/gcc/ada/5etpopse.adb deleted file mode 100644 index 957a58332f3..00000000000 --- a/gcc/ada/5etpopse.adb +++ /dev/null @@ -1,51 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SELF -- --- -- --- B o d y -- --- -- --- Copyright (C) 1991-1998, 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 Solaris/X86 (native) version of this package. - -separate (System.Task_Primitives.Operations) - ----------- --- Self -- ----------- - -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; 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/5mosinte.ads b/gcc/ada/5mosinte.ads deleted file mode 100644 index 17ed7f51025..00000000000 --- a/gcc/ada/5mosinte.ads +++ /dev/null @@ -1,559 +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 MACOS (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; - - pragma Linker_Options ("-lgthreads"); - - 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 := 35; - 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 - 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 - - SIGADAABORT : constant := SIGABRT; - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := (SIGTRAP, SIGALRM, SIGEMT, SIGCHLD); - Reserved : constant Signal_Set := (SIGKILL, 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_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_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 -- - --------------------------------------- - - 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, - "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); - - 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/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.adb b/gcc/ada/5qosinte.adb deleted file mode 100644 index 59d34acd4c8..00000000000 --- a/gcc/ada/5qosinte.adb +++ /dev/null @@ -1,48 +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 -- --- -- --- B o d y -- --- -- --- 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. - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -package body System.OS_Interface is - - type Require_Body is new Integer; - -end System.OS_Interface; 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/5qstache.adb b/gcc/ada/5qstache.adb deleted file mode 100644 index 58460cdfb0f..00000000000 --- a/gcc/ada/5qstache.adb +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- -- --- B o d y -- --- (Dummy version) -- --- -- --- Copyright (C) 2000 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. It is -- --- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- --- State University (http://www.gnat.com). -- --- -- ------------------------------------------------------------------------------- - -package body System.Stack_Checking is - - ----------------- - -- Stack_Check -- - ----------------- - - function Stack_Check (Stack_Address : System.Address) return Stack_Access is - begin - return null; - end Stack_Check; - - ---------------------------- - -- Invalidate_Stack_Cache -- - ---------------------------- - - procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is - begin - null; - end Invalidate_Stack_Cache; - - -------------------- - -- Set_Stack_Size -- - -------------------- - - -- Specify the stack size for the current frame. - - procedure Set_Stack_Size - (Stack_Size : System.Storage_Elements.Storage_Offset) is - begin - null; - end Set_Stack_Size; - - ------------------------ - -- Update_Stack_Cache -- - ------------------------ - - procedure Update_Stack_Cache (Stack : Stack_Access) is - begin - null; - end Update_Stack_Cache; - -end System.Stack_Checking; 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; - - <> - 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 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/5qtaspri.ads b/gcc/ada/5qtaspri.ads deleted file mode 100644 index 0bd2d2fe6ad..00000000000 --- a/gcc/ada/5qtaspri.ads +++ /dev/null @@ -1,138 +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 -- --- -- --- 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 - -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; - -- Used for implementation of protected objects. - - type Lock_Ptr is limited private; - - 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; - - 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 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. - 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 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 - 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/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 + + -- then force rebuilding your application if you need different options: + + -- $ gnatmake -f + + type Priorities_Mapping is array (Any_Priority) of Integer; + pragma Suppress_Initialization (Priorities_Mapping); + -- Suppress initialization in case gnat.adc specifies Normalize_Scalars + + Underlying_Priorities : constant Priorities_Mapping := + + (Priority'First => 16, + + 1 => 17, + 2 => 18, + 3 => 18, + 4 => 18, + 5 => 18, + 6 => 19, + 7 => 19, + 8 => 19, + 9 => 20, + 10 => 20, + 11 => 21, + 12 => 21, + 13 => 22, + 14 => 23, + + Default_Priority => 24, + + 16 => 25, + 17 => 25, + 18 => 25, + 19 => 26, + 20 => 26, + 21 => 26, + 22 => 27, + 23 => 27, + 24 => 27, + 25 => 28, + 26 => 28, + 27 => 29, + 28 => 29, + 29 => 30, + + Priority'Last => 30, + + Interrupt_Priority => 31); + + ---------------------------- + -- Special VMS Interfaces -- + ---------------------------- + + procedure Lib_Stop (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" & @@ -620,29 +625,20 @@ 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.a + + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + MLib.Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + -- Shared libraries are named : .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.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 : .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 + + -- then force rebuilding your application if you need different options: + + -- $ gnatmake -f + + type Priorities_Mapping is array (Any_Priority) of Integer; + pragma Suppress_Initialization (Priorities_Mapping); + -- Suppress initialization in case gnat.adc specifies Normalize_Scalars + + Underlying_Priorities : constant Priorities_Mapping := + + (Priority'First => 16, + + 1 => 17, + 2 => 18, + 3 => 18, + 4 => 18, + 5 => 18, + 6 => 19, + 7 => 19, + 8 => 19, + 9 => 20, + 10 => 20, + 11 => 21, + 12 => 21, + 13 => 22, + 14 => 23, + + Default_Priority => 24, + + 16 => 25, + 17 => 25, + 18 => 25, + 19 => 26, + 20 => 26, + 21 => 26, + 22 => 27, + 23 => 27, + 24 => 27, + 25 => 28, + 26 => 28, + 27 => 29, + 28 => 29, + 29 => 30, + + Priority'Last => 30, + + Interrupt_Priority => 31); + + ---------------------------- + -- Special VMS Interfaces -- + ---------------------------- + + procedure Lib_Stop (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/5xvxwork.ads b/gcc/ada/5xvxwork.ads new file mode 100644 index 00000000000..4183ee6bb1f --- /dev/null +++ b/gcc/ada/5xvxwork.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V X W O R K S -- +-- -- +-- S p e c -- +-- -- +-- 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- -- +-- 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 Xscale VxWorks version of this package. + +package System.VxWorks is + pragma Preelaborate (System.VxWorks); + + -- Floating point context record. Xscale version + + -- There is no floating point unit on Xscale. The record definition + -- below matches what arch/arm/fppArmLib.h says. + + 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/5ztpopsp.adb b/gcc/ada/5ztpopsp.adb new file mode 100644 index 00000000000..6a69c38b511 --- /dev/null +++ b/gcc/ada/5ztpopsp.adb @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 VxWorks version of this package where foreign threads are +-- recognized. + +separate (System.Task_Primitives.Operations) +package body Specific is + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + begin + return taskVarGet (taskIdSelf, ATCB_Key'Access) /= ERROR; + end Is_Valid_Task; + + --------- + -- Set -- + --------- + + procedure Set (Self_Id : Task_ID) is + Result : STATUS; + + begin + 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; + + ---------- + -- Self -- + ---------- + + function Self return Task_ID is + begin + return To_Task_Id (ATCB_Key); + end Self; + +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/7straces.adb b/gcc/ada/7straces.adb new file mode 100644 index 00000000000..46822242a40 --- /dev/null +++ b/gcc/ada/7straces.adb @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E S -- +-- -- +-- 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.Soft_Links; +with System.Parameters; +with System.Traces.Format; + +package body System.Traces is + + package SSL renames System.Soft_Links; + use System.Traces.Format; + + ---------------------- + -- Send_Trace_Info -- + ---------------------- + + 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 + + * 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 * 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//2.8.1/adalib/Makefile.adalib . +# $ cp /usr/local/gnat/lib/gcc-lib///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 +# : compile the specified file if needed. +# : 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 @@ -128,6 +142,13 @@ SOME_ADAFLAGS =-gnata FORCE_DEBUG_ADAFLAGS = -g 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) @@ -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 .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,698 +571,175 @@ 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 -- - -------------------------------------- + ----------------------- + -- Polling Interface -- + ----------------------- - 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; + type Unsigned is mod 2 ** 32; - 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; + 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. - 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 Poll is separate; + -- The actual polling routine is separate, so that it can easily + -- be replaced with a target dependent version. - 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; + --------- + -- AAA -- + --------- - 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; + -- This dummy procedure gives us the start of the PC range for addresses + -- within the exception unit itself. We hope that gigi/gcc keep all the + -- procedures in their original order! - procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer) is + procedure AAA is begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_05'Address)); - end Rcheck_05; + <> + Code_Address_For_AAA := Start_Of_AAA'Address; + end AAA; - 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; + ---------------- + -- Call_Chain -- + ---------------- - 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 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. - 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; + ------------------------------ + -- Current_Target_Exception -- + ------------------------------ - procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer) is + function Current_Target_Exception return Exception_Occurrence is begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_09'Address)); - end Rcheck_09; + return Null_Occurrence; + end Current_Target_Exception; - 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; + ------------------- + -- EId_To_String -- + ------------------- - 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; + function EId_To_String (X : Exception_Id) return String + renames Stream_Attributes.EId_To_String; - 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; + ------------------ + -- EO_To_String -- + ------------------ - 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; + -- We use the null string to represent the null occurrence, otherwise + -- we output the Exception_Information string for the occurrence. - 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; + function EO_To_String (X : Exception_Occurrence) return String + renames Stream_Attributes.EO_To_String; - 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; + ------------------------ + -- Exception_Identity -- + ------------------------ - procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer) is + function Exception_Identity + (X : Exception_Occurrence) + return Exception_Id + is begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_16'Address)); - end Rcheck_16; + if X.Id = Null_Id then + raise Constraint_Error; + else + return X.Id; + end if; + end Exception_Identity; - 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; + --------------------------- + -- Exception_Information -- + --------------------------- - 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; + function Exception_Information (X : Exception_Occurrence) return String + renames Exception_Data.Exception_Information; - 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; + ----------------------- + -- Exception_Message -- + ----------------------- - procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer) is + function Exception_Message (X : Exception_Occurrence) return String is begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_20'Address)); - end Rcheck_20; + if X.Id = Null_Id then + raise Constraint_Error; + end if; - 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; + return X.Msg (1 .. X.Msg_Length); + end Exception_Message; - 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; + -------------------- + -- Exception_Name -- + -------------------- - procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer) is + function Exception_Name (Id : Exception_Id) return String is begin - Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_23'Address)); - end Rcheck_23; + if Id = null then + raise Constraint_Error; + end if; - 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; + return Id.Full_Name.all (1 .. Id.Name_Length - 1); + end Exception_Name; - procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer) is + function Exception_Name (X : Exception_Occurrence) return String is begin - Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_25'Address)); - end Rcheck_25; + return Exception_Name (X.Id); + end Exception_Name; - 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; + --------------------------- + -- Exception_Name_Simple -- + --------------------------- - 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; + function Exception_Name_Simple (X : Exception_Occurrence) return String is + Name : constant String := Exception_Name (X); + P : Natural; - 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 -- - --------------------------------------- + P := Name'Length; + while P > 1 loop + exit when Name (P - 1) = '.'; + P := P - 1; + end loop; - -- 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 : + return Name (P .. Name'Length); + end Exception_Name_Simple; - 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. + -------------------- + -- Exception_Data -- + -------------------- - 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. + 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). - 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. + --------------------------- + -- Exception_Propagation -- + --------------------------- - 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. + 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. - -- 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 -- - ----------------------- - - type Unsigned is mod 2 ** 32; - - Counter : Unsigned := 0; - -- This counter is provided for convenience. It can be used in Poll to - -- perform periodic but not systematic operations. - - procedure Poll is separate; - -- The actual polling routine is separate, so that it can easily - -- be replaced with a target dependent version. - - --------- - -- AAA -- - --------- - - -- This dummy procedure gives us the start of the PC range for addresses - -- within the exception unit itself. We hope that gigi/gcc keep all the - -- procedures in their original order! - - procedure AAA is - begin - null; - 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; - - ------------------------------ - -- Current_Target_Exception -- - ------------------------------ - - function Current_Target_Exception return Exception_Occurrence is - begin - return Null_Occurrence; - end Current_Target_Exception; - - ------------------- - -- 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; - - ------------------------ - -- Exception_Identity -- - ------------------------ - - function Exception_Identity - (X : Exception_Occurrence) - return Exception_Id - is - begin - if X.Id = Null_Id then - raise Constraint_Error; - else - return X.Id; - end if; - end Exception_Identity; - - --------------------------- - -- 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); + ---------------------- + -- Exception_Traces -- + ---------------------- - return Info; - end Exception_Information; + 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. ----------------------- - -- Exception_Message -- + -- Stream Attributes -- ----------------------- - function Exception_Message (X : Exception_Occurrence) return String is - begin - if X.Id = Null_Id then - raise Constraint_Error; - end if; - - return X.Msg (1 .. X.Msg_Length); - end Exception_Message; - - -------------------- - -- Exception_Name -- - -------------------- - - function Exception_Name (Id : Exception_Id) return String is - begin - if Id = null then - raise Constraint_Error; - end if; - - return Id.Full_Name.all (1 .. Id.Name_Length - 1); - end Exception_Name; - - function Exception_Name (X : Exception_Occurrence) return String is - begin - return Exception_Name (X.Id); - end Exception_Name; - - --------------------------- - -- Exception_Name_Simple -- - --------------------------- - - function Exception_Name_Simple (X : Exception_Occurrence) return String is - Name : constant String := Exception_Name (X); - P : Natural; - - begin - P := Name'Length; - while P > 1 loop - exit when Name (P - 1) = '.'; - P := P - 1; - end loop; - - return Name (P .. Name'Length); - end Exception_Name_Simple; + 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; + -- The pragma Inspection point here ensures that the debugger + -- can inspect the parameter. - end Process_Raise_Exception; + pragma Inspection_Point (E); - ----------------------------------------- - -- 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 - - -- Record location unless we already recorded max tracebacks - - 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,67 +961,205 @@ package body Ada.Exceptions is (Storage_Error_Def'Access, File, Line, Msg); end Raise_Storage_Error_Msg; - ---------------------- - -- Raise_With_C_Msg -- - ---------------------- + --------------------------------- + -- Raise_With_Location_And_Msg -- + --------------------------------- - procedure Raise_With_C_Msg + procedure Raise_With_Location_And_Msg (E : Exception_Id; - M : Big_String_Ptr) + F : Big_String_Ptr; + L : Integer; + M : Big_String_Ptr := null) is begin - Set_Exception_C_Msg (E, M); + Exception_Data.Set_Exception_C_Msg (E, F, L, M); Abort_Defer.all; Raise_Current_Excep (E); - end Raise_With_C_Msg; + end Raise_With_Location_And_Msg; - ------------------------- - -- Raise_With_Location -- - ------------------------- + -------------------- + -- Raise_With_Msg -- + -------------------- + + procedure Raise_With_Msg (E : Exception_Id; Setup : Boolean) is + Excep : constant EOA := Get_Current_Excep.all; - procedure Raise_With_Location - (E : Exception_Id; - F : Big_String_Ptr; - L : Integer) - is begin - Set_Exception_C_Msg (E, F, L); + if not Setup then + Exception_Propagation.Setup_Exception (Excep, Excep); + end if; + + Excep.Exception_Raised := False; + Excep.Id := E; + Excep.Num_Tracebacks := 0; + Excep.Cleanup_Flag := False; + Excep.Pid := Local_Partition_ID; Abort_Defer.all; Raise_Current_Excep (E); - end Raise_With_Location; + end Raise_With_Msg; - --------------------------------- - -- Raise_With_Location_And_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 Raise_With_Location_And_Msg - (E : Exception_Id; - F : Big_String_Ptr; - L : Integer; - M : Big_String_Ptr) - is + procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer) is begin - Set_Exception_C_Msg (E, F, L, M); - Abort_Defer.all; - Raise_Current_Excep (E); - end Raise_With_Location_And_Msg; + Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_25'Address)); + end Rcheck_25; - -------------------- - -- Raise_With_Msg -- - -------------------- + 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 Raise_With_Msg (E : Exception_Id) is - Excep : constant EOA := Get_Current_Excep.all; + 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 - Excep.Exception_Raised := False; - Excep.Id := E; - Excep.Num_Tracebacks := 0; - Excep.Cleanup_Flag := False; - Excep.Pid := Local_Partition_ID; - Abort_Defer.all; - Raise_Current_Excep (E); - end Raise_With_Msg; + 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); + Save_Occurrence_No_Private (Target, Source); + Target.Private_Data := Source.Private_Data; + end Save_Occurrence_And_Private; - -- 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. - - 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; + <> + 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,122 +31,10 @@ -- -- ------------------------------------------------------------------------------ -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,122 +31,10 @@ -- -- ------------------------------------------------------------------------------ -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/adafinal.c b/gcc/ada/adafinal.c deleted file mode 100644 index 06e1f462a46..00000000000 --- a/gcc/ada/adafinal.c +++ /dev/null @@ -1,56 +0,0 @@ -/**************************************************************************** - * * - * GNAT COMPILER COMPONENTS * - * * - * A D A F I N A L * - * * - * * - * 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. * - * * - ****************************************************************************/ - -#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" - -/* 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 - at all, the intention is that this be replaced by system specific code - where finalization is required. */ - -void -__gnat_finalize () -{ -} 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 #include #include @@ -65,7 +65,23 @@ #include "config.h" #include "system.h" #endif + +#ifdef __MINGW32__ +#include "mingw32.h" +#include +#else +#ifndef VMS +#include +#endif +#endif + +#ifdef __MINGW32__ +#if OLD_MINGW #include +#endif +#else +#include +#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 +#endif #else #include -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 -#endif - #include -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; + + <> 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: + -- 494b25 + -- ??? 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; - <> + <> 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 @@ -2696,6 +2698,74 @@ package body Bindgen is Linker_Options.Table (To) := Linker_Options.Table (From); 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 __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 __CASE__ 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 $__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