diff options
| author | Arnaud Charlet <charlet@act-europe.fr> | 2003-10-21 15:42:24 +0200 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2003-10-21 15:42:24 +0200 |
| commit | fbf5a39b3e101719c6bf03cf2cd013b4a312e275 (patch) | |
| tree | bdfc70477b60f1220cb05dd233a4570dd9c6bb5c /gcc/ada/vms_conv.adb | |
| parent | 75a5a481c2048242ed62c7355381160aa1369616 (diff) | |
| download | gcc-fbf5a39b3e101719c6bf03cf2cd013b4a312e275.zip gcc-fbf5a39b3e101719c6bf03cf2cd013b4a312e275.tar.gz gcc-fbf5a39b3e101719c6bf03cf2cd013b4a312e275.tar.bz2 | |
3psoccon.ads, [...]: Files added.
2003-10-21 Arnaud Charlet <charlet@act-europe.fr>
* 3psoccon.ads, 3veacodu.adb, 3vexpect.adb, 3vsoccon.ads,
3vsocthi.adb, 3vsocthi.ads, 3vtrasym.adb, 3zsoccon.ads,
3zsocthi.adb, 3zsocthi.ads, 50system.ads, 51system.ads,
55system.ads, 56osinte.adb, 56osinte.ads, 56taprop.adb,
56taspri.ads, 56tpopsp.adb, 57system.ads, 58system.ads,
59system.ads, 5aml-tgt.adb, 5bml-tgt.adb, 5csystem.ads,
5dsystem.ads, 5fosinte.adb, 5gml-tgt.adb, 5hml-tgt.adb,
5isystem.ads, 5lparame.adb, 5msystem.ads, 5psystem.ads,
5sml-tgt.adb, 5sosprim.adb, 5stpopsp.adb, 5tsystem.ads,
5usystem.ads, 5vml-tgt.adb, 5vsymbol.adb, 5vtraent.adb,
5vtraent.ads, 5wml-tgt.adb, 5xparame.ads, 5xsystem.ads,
5xvxwork.ads, 5yparame.ads, 5ytiitho.adb, 5zinit.adb,
5zml-tgt.adb, 5zparame.ads, 5ztaspri.ads, 5ztfsetr.adb,
5zthrini.adb, 5ztiitho.adb, 5ztpopsp.adb, 7stfsetr.adb,
7straces.adb, 7strafor.adb, 7strafor.ads, 7stratas.adb,
a-excach.adb, a-exexda.adb, a-exexpr.adb, a-exextr.adb,
a-exstat.adb, a-strsup.adb, a-strsup.ads, a-stwisu.adb,
a-stwisu.ads, bld.adb, bld.ads, bld-io.adb,
bld-io.ads, clean.adb, clean.ads, ctrl_c.c,
erroutc.adb, erroutc.ads, errutil.adb, errutil.ads,
err_vars.ads, final.c, g-arrspl.adb, g-arrspl.ads,
g-boubuf.adb, g-boubuf.ads, g-boumai.ads, g-bubsor.adb,
g-bubsor.ads, g-comver.adb, g-comver.ads, g-ctrl_c.ads,
g-dynhta.adb, g-dynhta.ads, g-eacodu.adb, g-excact.adb,
g-excact.ads, g-heasor.adb, g-heasor.ads, g-memdum.adb,
g-memdum.ads, gnatclean.adb, gnatsym.adb, g-pehage.adb,
g-pehage.ads, g-perhas.ads, gpr2make.adb, gpr2make.ads,
gprcmd.adb, gprep.adb, gprep.ads, g-semaph.adb,
g-semaph.ads, g-string.adb, g-string.ads, g-strspl.ads,
g-wistsp.ads, i-vthrea.adb, i-vthrea.ads, i-vxwoio.adb,
i-vxwoio.ads, Makefile.generic, Makefile.prolog, Makefile.rtl,
prep.adb, prep.ads, prepcomp.adb, prepcomp.ads,
prj-err.adb, prj-err.ads, s-boarop.ads, s-carsi8.adb,
s-carsi8.ads, s-carun8.adb, s-carun8.ads, s-casi16.adb,
s-casi16.ads, s-casi32.adb, s-casi32.ads, s-casi64.adb,
s-casi64.ads, s-casuti.adb, s-casuti.ads, s-caun16.adb,
s-caun16.ads, s-caun32.adb, s-caun32.ads, s-caun64.adb,
s-caun64.ads, scng.adb, scng.ads, s-exnint.adb,
s-exnllf.adb, s-exnlli.adb, s-expint.adb, s-explli.adb,
s-geveop.adb, s-geveop.ads, s-hibaen.ads, s-htable.adb,
s-htable.ads, sinput-c.adb, sinput-c.ads, s-memcop.ads,
socket.c, s-purexc.ads, s-scaval.adb, s-stopoo.adb,
s-strcom.adb, s-strcom.ads, s-strxdr.adb, s-rident.ads,
s-thread.adb, s-thread.ads, s-tpae65.adb, s-tpae65.ads,
s-tporft.adb, s-traent.adb, s-traent.ads, styleg.adb,
styleg.ads, styleg-c.adb, styleg-c.ads, s-veboop.adb,
s-veboop.ads, s-vector.ads, symbols.adb, symbols.ads,
tb-alvms.c, tb-alvxw.c, tempdir.adb, tempdir.ads,
vms_conv.ads, vms_conv.adb, vms_data.ads,
vxaddr2line.adb: Files added. Merge with ACT tree.
* 4dintnam.ads, 4mintnam.ads, 4uintnam.ads, 52system.ads,
5dosinte.ads, 5etpopse.adb, 5mosinte.ads, 5qosinte.adb,
5qosinte.ads, 5qstache.adb, 5qtaprop.adb, 5qtaspri.ads,
5stpopse.adb, 5uintman.adb, 5uosinte.ads, adafinal.c,
g-enblsp.adb, io-aux.c, scn-nlit.adb, scn-slit.adb,
s-exnflt.ads, s-exngen.adb, s-exngen.ads, s-exnlfl.ads,
s-exnlin.ads, s-exnsfl.ads, s-exnsin.ads, s-exnssi.ads,
s-expflt.ads, s-expgen.adb, s-expgen.ads, s-explfl.ads,
s-explin.ads, s-expllf.ads, s-expsfl.ads, s-expsin.ads,
s-expssi.ads, style.adb: Files removed. Merge with ACT tree.
* 1ic.ads, 31soccon.ads, 31soliop.ads, 3asoccon.ads,
3bsoccon.ads, 3gsoccon.ads, 3hsoccon.ads, 3ssoccon.ads,
3ssoliop.ads, 3wsoccon.ads, 3wsocthi.adb, 3wsocthi.ads,
3wsoliop.ads, 41intnam.ads, 42intnam.ads, 4aintnam.ads,
4cintnam.ads, 4gintnam.ads, 4hexcpol.adb, 4hintnam.ads,
4lintnam.ads, 4nintnam.ads, 4ointnam.ads, 4onumaux.ads,
4pintnam.ads, 4sintnam.ads, 4vcaldel.adb, 4vcalend.adb,
4vintnam.ads, 4wexcpol.adb, 4wintnam.ads, 4zintnam.ads,
51osinte.adb, 51osinte.ads, 52osinte.adb, 52osinte.ads,
53osinte.ads, 54osinte.ads, 5aosinte.adb, 5aosinte.ads,
5asystem.ads, 5ataprop.adb, 5atasinf.ads, 5ataspri.ads,
5atpopsp.adb, 5avxwork.ads, 5bosinte.adb, 5bosinte.ads,
5bsystem.ads, 5cosinte.ads, 5esystem.ads, 5fintman.adb,
5fosinte.ads, 5fsystem.ads, 5ftaprop.adb, 5ftasinf.ads,
5ginterr.adb, 5gintman.adb, 5gmastop.adb, 5gosinte.ads,
5gproinf.ads, 5gsystem.ads, 5gtaprop.adb, 5gtasinf.ads,
5gtpgetc.adb, 5hosinte.adb, 5hosinte.ads, 5hsystem.ads,
5htaprop.adb, 5htaspri.ads, 5htraceb.adb, 5iosinte.adb,
5itaprop.adb, 5itaspri.ads, 5ksystem.ads, 5kvxwork.ads,
5lintman.adb, 5lml-tgt.adb, 5losinte.ads, 5lsystem.ads,
5mvxwork.ads, 5ninmaop.adb, 5nintman.adb, 5nosinte.ads,
5ntaprop.adb, 5ntaspri.ads, 5ointerr.adb, 5omastop.adb,
5oosinte.adb, 5oosinte.ads, 5oosprim.adb, 5oparame.adb,
5osystem.ads, 5otaprop.adb, 5otaspri.ads, 5posinte.ads,
5posprim.adb, 5pvxwork.ads, 5sintman.adb, 5sosinte.adb,
5sosinte.ads, 5ssystem.ads, 5staprop.adb, 5stasinf.ads,
5staspri.ads, 5svxwork.ads, 5tosinte.ads, 5vasthan.adb,
5vinmaop.adb, 5vinterr.adb, 5vintman.adb, 5vintman.ads,
5vmastop.adb, 5vosinte.adb, 5vosinte.ads, 5vosprim.adb,
5vsystem.ads, 5vtaprop.adb, 5vtaspri.ads, 5vtpopde.adb,
5vtpopde.ads, 5wgloloc.adb, 5wintman.adb, 5wmemory.adb,
5wosprim.adb, 5wsystem.ads, 5wtaprop.adb, 5wtaspri.ads,
5ysystem.ads, 5zinterr.adb, 5zintman.adb, 5zosinte.adb,
5zosinte.ads, 5zosprim.adb, 5zsystem.ads, 5ztaprop.adb,
6vcpp.adb, 6vcstrea.adb, 6vinterf.ads, 7sinmaop.adb,
7sintman.adb, 7sosinte.adb, 7sosprim.adb, 7staprop.adb,
7staspri.ads, 7stpopsp.adb, 7straceb.adb, 9drpc.adb,
a-caldel.adb, a-caldel.ads, a-charac.ads, a-colien.ads,
a-comlin.adb, adaint.c, adaint.h, ada-tree.def,
a-diocst.adb, a-diocst.ads, a-direio.adb, a-except.adb,
a-except.ads, a-excpol.adb, a-exctra.adb, a-exctra.ads,
a-filico.adb, a-interr.adb, a-intsig.adb, a-intsig.ads,
ali.adb, ali.ads, ali-util.adb, ali-util.ads,
a-ngcefu.adb, a-ngcoty.adb, a-ngelfu.adb, a-nudira.adb,
a-nudira.ads, a-nuflra.adb, a-nuflra.ads, a-reatim.adb,
a-reatim.ads, a-retide.ads, a-sequio.adb, a-siocst.adb,
a-siocst.ads, a-ssicst.adb, a-ssicst.ads, a-strbou.adb,
a-strbou.ads, a-strfix.adb, a-strmap.adb, a-strsea.ads,
a-strunb.adb, a-strunb.ads, a-ststio.adb, a-stunau.adb,
a-stunau.ads, a-stwibo.adb, a-stwibo.ads, a-stwifi.adb,
a-stwima.adb, a-stwiun.adb, a-stwiun.ads, a-tags.adb,
a-tags.ads, a-tasatt.adb, a-taside.adb, a-teioed.adb,
a-textio.adb, a-textio.ads, a-tienau.adb, a-tifiio.adb,
a-tiflau.adb, a-tiflio.adb, a-tigeau.adb, a-tigeau.ads,
a-tiinau.adb, a-timoau.adb, a-tiocst.adb, a-tiocst.ads,
atree.adb, atree.ads, a-witeio.adb, a-witeio.ads,
a-wtcstr.adb, a-wtcstr.ads, a-wtdeio.adb, a-wtedit.adb,
a-wtenau.adb, a-wtflau.adb, a-wtinau.adb, a-wtmoau.adb,
bcheck.adb, binde.adb, bindgen.adb, bindusg.adb,
checks.adb, checks.ads, cio.c, comperr.adb,
comperr.ads, csets.adb, cstand.adb, cstreams.c,
debug_a.adb, debug_a.ads, debug.adb, decl.c,
einfo.adb, einfo.ads, errout.adb, errout.ads,
eval_fat.adb, eval_fat.ads, exp_aggr.adb, expander.adb,
expander.ads, exp_attr.adb, exp_ch11.adb, exp_ch13.adb,
exp_ch2.adb, exp_ch3.adb, exp_ch3.ads, exp_ch4.adb,
exp_ch5.adb, exp_ch6.adb, exp_ch7.adb, exp_ch7.ads,
exp_ch8.adb, exp_ch9.adb, exp_code.adb, exp_dbug.adb,
exp_dbug.ads, exp_disp.adb, exp_dist.adb, expect.c,
exp_fixd.adb, exp_imgv.adb, exp_intr.adb, exp_pakd.adb,
exp_prag.adb, exp_strm.adb, exp_strm.ads, exp_tss.adb,
exp_tss.ads, exp_util.adb, exp_util.ads, exp_vfpt.adb,
fe.h, fmap.adb, fmap.ads, fname.adb,
fname.ads, fname-uf.adb, fname-uf.ads, freeze.adb,
freeze.ads, frontend.adb, g-awk.adb, g-awk.ads,
g-busora.adb, g-busora.ads, g-busorg.adb, g-busorg.ads,
g-casuti.adb, g-casuti.ads, g-catiio.adb, g-catiio.ads,
g-cgi.adb, g-cgi.ads, g-cgicoo.adb, g-cgicoo.ads,
g-cgideb.adb, g-cgideb.ads, g-comlin.adb, g-comlin.ads,
g-crc32.adb, g-crc32.ads, g-debpoo.adb, g-debpoo.ads,
g-debuti.adb, g-debuti.ads, g-diopit.adb, g-diopit.ads,
g-dirope.adb, g-dirope.ads, g-dyntab.adb, g-dyntab.ads,
g-except.ads, g-exctra.adb, g-exctra.ads, g-expect.adb,
g-expect.ads, g-hesora.adb, g-hesora.ads, g-hesorg.adb,
g-hesorg.ads, g-htable.adb, g-htable.ads, gigi.h,
g-io.adb, g-io.ads, g-io_aux.adb, g-io_aux.ads,
g-locfil.adb, g-locfil.ads, g-md5.adb, g-md5.ads,
gmem.c, gnat1drv.adb, gnatbind.adb, gnatchop.adb,
gnatcmd.adb, gnatfind.adb, gnatkr.adb, gnatlbr.adb,
gnatlink.adb, gnatls.adb, gnatmake.adb, gnatmem.adb,
gnatname.adb, gnatprep.adb, gnatprep.ads, gnatpsta.adb,
gnatxref.adb, g-os_lib.adb, g-os_lib.ads, g-regexp.adb,
g-regexp.ads, g-regist.adb, g-regist.ads, g-regpat.adb,
g-regpat.ads, g-soccon.ads, g-socket.adb, g-socket.ads,
g-socthi.adb, g-socthi.ads, g-soliop.ads, g-souinf.ads,
g-speche.adb, g-speche.ads, g-spipat.adb, g-spipat.ads,
g-spitbo.adb, g-spitbo.ads, g-sptabo.ads, g-sptain.ads,
g-sptavs.ads, g-table.adb, g-table.ads, g-tasloc.adb,
g-tasloc.ads, g-thread.adb, g-thread.ads, g-traceb.adb,
g-traceb.ads, g-trasym.adb, g-trasym.ads, hostparm.ads,
i-c.ads, i-cobol.adb, i-cpp.adb, i-cstrea.ads,
i-cstrin.adb, i-cstrin.ads, impunit.adb, init.c,
inline.adb, interfac.ads, i-pacdec.ads, itypes.adb,
itypes.ads, i-vxwork.ads, lang.opt, lang-specs.h,
layout.adb, lib.adb, lib.ads, lib-list.adb,
lib-load.adb, lib-load.ads, lib-sort.adb, lib-util.adb,
lib-writ.adb, lib-writ.ads, lib-xref.adb, lib-xref.ads,
link.c, live.adb, make.adb, make.ads,
Makefile.adalib, Makefile.in, Make-lang.in, makeusg.adb,
mdll.adb, mdll-fil.adb, mdll-fil.ads, mdll-utl.adb,
mdll-utl.ads, memroot.adb, memroot.ads, memtrack.adb,
misc.c, mkdir.c, mlib.adb, mlib.ads,
mlib-fil.adb, mlib-fil.ads, mlib-prj.adb, mlib-prj.ads,
mlib-tgt.adb, mlib-tgt.ads, mlib-utl.adb, mlib-utl.ads,
namet.adb, namet.ads, namet.h, nlists.ads,
nlists.h, nmake.adt, opt.adb, opt.ads,
osint.adb, osint.ads, osint-b.adb, osint-c.adb,
par.adb, par-ch10.adb, par-ch11.adb, par-ch2.adb,
par-ch3.adb, par-ch4.adb, par-ch5.adb, par-ch6.adb,
par-ch9.adb, par-endh.adb, par-labl.adb, par-load.adb,
par-prag.adb, par-sync.adb, par-tchk.adb, par-util.adb,
prj.adb, prj.ads, prj-attr.adb, prj-attr.ads,
prj-com.adb, prj-com.ads, prj-dect.adb, prj-dect.ads,
prj-env.adb, prj-env.ads, prj-ext.adb, prj-ext.ads,
prj-makr.adb, prj-makr.ads, prj-nmsc.adb, prj-nmsc.ads,
prj-pars.adb, prj-pars.ads, prj-part.adb, prj-part.ads,
prj-pp.adb, prj-pp.ads, prj-proc.adb, prj-proc.ads,
prj-strt.adb, prj-strt.ads, prj-tree.adb, prj-tree.ads,
prj-util.adb, prj-util.ads, raise.c, raise.h,
repinfo.adb, repinfo.h, restrict.adb, restrict.ads,
rident.ads, rtsfind.adb, rtsfind.ads, s-addima.ads,
s-arit64.adb, s-assert.adb, s-assert.ads, s-atacco.adb,
s-atacco.ads, s-auxdec.adb, s-auxdec.ads, s-bitops.adb,
scans.ads, scn.adb, scn.ads, s-crc32.adb,
s-crc32.ads, s-direio.adb, sem.adb, sem.ads,
sem_aggr.adb, sem_attr.adb, sem_attr.ads, sem_case.adb,
sem_case.ads, sem_cat.adb, sem_cat.ads, sem_ch10.adb,
sem_ch11.adb, sem_ch12.adb, sem_ch12.ads, sem_ch13.adb,
sem_ch13.ads, sem_ch3.adb, sem_ch3.ads, sem_ch4.adb,
sem_ch5.adb, sem_ch5.ads, sem_ch6.adb, sem_ch6.ads,
sem_ch7.adb, sem_ch7.ads, sem_ch8.adb, sem_ch8.ads,
sem_ch9.adb, sem_disp.adb, sem_disp.ads, sem_dist.adb,
sem_elab.adb, sem_eval.adb, sem_eval.ads, sem_intr.adb,
sem_maps.adb, sem_mech.adb, sem_prag.adb, sem_prag.ads,
sem_res.adb, sem_res.ads, sem_type.adb, sem_type.ads,
sem_util.adb, sem_util.ads, sem_warn.adb, s-errrep.adb,
s-errrep.ads, s-exctab.adb, s-exctab.ads, s-exnint.ads,
s-exnllf.ads, s-exnlli.ads, s-expint.ads, s-explli.ads,
s-expuns.ads, s-fatflt.ads, s-fatgen.adb, s-fatgen.ads,
s-fatlfl.ads, s-fatllf.ads, s-fatsfl.ads, s-fileio.adb,
s-fileio.ads, s-finimp.adb, s-finimp.ads, s-finroo.adb,
s-finroo.ads, sfn_scan.adb, s-gloloc.adb, s-gloloc.ads,
s-imgdec.adb, s-imgenu.adb, s-imgrea.adb, s-imgwch.adb,
sinfo.adb, sinfo.ads, s-inmaop.ads, sinput.adb,
sinput.ads, sinput-d.adb, sinput-l.adb, sinput-l.ads,
sinput-p.adb, sinput-p.ads, s-interr.adb, s-interr.ads,
s-intman.ads, s-maccod.ads, s-mastop.adb, s-mastop.ads,
s-memory.adb, s-memory.ads, snames.adb, snames.ads,
snames.h, s-osprim.ads, s-parame.ads, s-parint.ads,
s-pooloc.adb, s-pooloc.ads, s-poosiz.adb, sprint.adb,
s-proinf.ads, s-scaval.ads, s-secsta.adb, s-secsta.ads,
s-sequio.adb, s-shasto.adb, s-shasto.ads, s-soflin.ads,
s-stache.adb, s-stache.ads, s-stalib.adb, s-stalib.ads,
s-stoele.ads, s-stopoo.ads, s-stratt.adb, s-stratt.ads,
s-strops.adb, s-strops.ads, s-taasde.adb, s-taasde.ads,
s-tadeca.adb, s-tadeca.ads, s-tadert.adb, s-tadert.ads,
s-taenca.adb, s-taenca.ads, s-taprob.adb, s-taprob.ads,
s-taprop.ads, s-tarest.adb, s-tarest.ads, s-tasdeb.adb,
s-tasdeb.ads, s-tasinf.adb, s-tasinf.ads, s-tasini.adb,
s-tasini.ads, s-taskin.adb, s-taskin.ads, s-tasque.adb,
s-tasque.ads, s-tasren.adb, s-tasren.ads, s-tasres.ads,
s-tassta.adb, s-tassta.ads, s-tasuti.adb, s-tasuti.ads,
s-tataat.adb, s-tataat.ads, s-tpinop.adb, s-tpinop.ads,
s-tpoben.adb, s-tpoben.ads, s-tpobop.adb, s-tpobop.ads,
s-tposen.adb, s-tposen.ads, s-traceb.adb, s-traceb.ads,
stringt.adb, stringt.ads, stringt.h, style.ads,
stylesw.adb, stylesw.ads, s-unstyp.ads, s-vaflop.ads,
s-valrea.adb, s-valuti.adb, s-vercon.adb, s-vmexta.adb,
s-wchcnv.ads, s-wchcon.ads, s-widcha.adb, switch.adb,
switch.ads, switch-b.adb, switch-c.adb, switch-m.adb,
s-wwdcha.adb, s-wwdwch.adb, sysdep.c, system.ads,
table.adb, table.ads, targparm.adb, targparm.ads,
targtyps.c, tbuild.adb, tbuild.ads, tracebak.c,
trans.c, tree_io.adb, treepr.adb, treeprs.adt,
ttypes.ads, types.ads, types.h, uintp.adb,
uintp.ads, uintp.h, uname.adb, urealp.adb,
urealp.ads, urealp.h, usage.adb, utils2.c,
utils.c, validsw.adb, validsw.ads, widechar.adb,
xeinfo.adb, xnmake.adb, xref_lib.adb, xref_lib.ads,
xr_tabls.adb, xr_tabls.ads, xtreeprs.adb, xsnames.adb,
einfo.h, sinfo.h, treeprs.ads, nmake.ads, nmake.adb,
gnatvsn.ads: Merge with ACT tree.
* gnatvsn.adb: Rewritten in a simpler and more efficient way.
From-SVN: r72751
Diffstat (limited to 'gcc/ada/vms_conv.adb')
| -rw-r--r-- | gcc/ada/vms_conv.adb | 1998 |
1 files changed, 1998 insertions, 0 deletions
diff --git a/gcc/ada/vms_conv.adb b/gcc/ada/vms_conv.adb new file mode 100644 index 0000000..f028b30 --- /dev/null +++ b/gcc/ada/vms_conv.adb @@ -0,0 +1,1998 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- V M S _ C O N V -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-2003 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Hostparm; +with Osint; use Osint; +with Sdefault; use Sdefault; + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Text_IO; use Ada.Text_IO; + +with Gnatvsn; + +package body VMS_Conv is + + Param_Count : Natural := 0; + -- Number of parameter arguments so far + + Arg_Num : Natural; + -- Argument number + + Commands : Item_Ptr; + -- Pointer to head of list of command items, one for each command, with + -- the end of the list marked by a null pointer. + + Last_Command : Item_Ptr; + -- Pointer to last item in Commands list + + Command : Item_Ptr; + -- Pointer to command item for current command + + Make_Commands_Active : Item_Ptr := null; + -- Set to point to Command entry for COMPILE, BIND, or LINK as appropriate + -- if a COMMANDS_TRANSLATION switch has been encountered while processing + -- a MAKE Command. + + package Buffer is new Table.Table + (Table_Component_Type => Character, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 4096, + Table_Increment => 2, + Table_Name => "Buffer"); + + function Init_Object_Dirs return Argument_List; + -- Get the list of the object directories + + function Invert_Sense (S : String) return VMS_Data.String_Ptr; + -- Given a unix switch string S, computes the inverse (adding or + -- removing ! characters as required), and returns a pointer to + -- the allocated result on the heap. + + function Is_Extensionless (F : String) return Boolean; + -- Returns true if the filename has no extension. + + function Match (S1, S2 : String) return Boolean; + -- Determines whether S1 and S2 match. This is a case insensitive match. + + function Match_Prefix (S1, S2 : String) return Boolean; + -- Determines whether S1 matches a prefix of S2. This is also a case + -- insensitive match (for example Match ("AB","abc") is True). + + function Matching_Name + (S : String; + Itm : Item_Ptr; + Quiet : Boolean := False) + return Item_Ptr; + -- Determines if the item list headed by Itm and threaded through the + -- Next fields (with null marking the end of the list), contains an + -- entry that uniquely matches the given string. The match is case + -- insensitive and permits unique abbreviation. If the match succeeds, + -- then a pointer to the matching item is returned. Otherwise, an + -- appropriate error message is written. Note that the discriminant + -- of Itm is used to determine the appropriate form of this message. + -- Quiet is normally False as shown, if it is set to True, then no + -- error message is generated in a not found situation (null is still + -- returned to indicate the not-found situation). + + function OK_Alphanumerplus (S : String) return Boolean; + -- Checks that S is a string of alphanumeric characters, + -- returning True if all alphanumeric characters, + -- False if empty or a non-alphanumeric character is present. + + function OK_Integer (S : String) return Boolean; + -- Checks that S is a string of digits, returning True if all digits, + -- False if empty or a non-digit is present. + + procedure Place (C : Character); + -- Place a single character in the buffer, updating Ptr + + procedure Place (S : String); + -- Place a string character in the buffer, updating Ptr + + procedure Place_Lower (S : String); + -- Place string in buffer, forcing letters to lower case, updating Ptr + + procedure Place_Unix_Switches (S : VMS_Data.String_Ptr); + -- Given a unix switch string, place corresponding switches in Buffer, + -- updating Ptr appropriatelly. Note that in the case of use of ! the + -- result may be to remove a previously placed switch. + + procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr); + -- Check that N is a valid command or option name, i.e. that it is of the + -- form of an Ada identifier with upper case letters and underscores. + + procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr); + -- Check that S is a valid switch string as described in the syntax for + -- the switch table item UNIX_SWITCH or else begins with a backquote. + + ---------------------- + -- Init_Object_Dirs -- + ---------------------- + + function Init_Object_Dirs return Argument_List is + Object_Dirs : Integer; + Object_Dir : Argument_List (1 .. 256); + Object_Dir_Name : String_Access; + + begin + Object_Dirs := 0; + Object_Dir_Name := String_Access (Object_Dir_Default_Name); + Get_Next_Dir_In_Path_Init (Object_Dir_Name); + + loop + declare + Dir : constant String_Access := + String_Access (Get_Next_Dir_In_Path (Object_Dir_Name)); + begin + exit when Dir = null; + Object_Dirs := Object_Dirs + 1; + Object_Dir (Object_Dirs) := + new String'("-L" & + To_Canonical_Dir_Spec + (To_Host_Dir_Spec + (Normalize_Directory_Name (Dir.all).all, + True).all, True).all); + end; + end loop; + + Object_Dirs := Object_Dirs + 1; + Object_Dir (Object_Dirs) := new String'("-lgnat"); + + if Hostparm.OpenVMS then + Object_Dirs := Object_Dirs + 1; + Object_Dir (Object_Dirs) := new String'("-ldecgnat"); + end if; + + return Object_Dir (1 .. Object_Dirs); + end Init_Object_Dirs; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Command_List := + (Bind => + (Cname => new S'("BIND"), + Usage => new S'("GNAT BIND file[.ali] /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatbind"), + Unixsws => null, + Switches => Bind_Switches'Access, + Params => new Parameter_Array'(1 => File), + Defext => "ali"), + + Chop => + (Cname => new S'("CHOP"), + Usage => new S'("GNAT CHOP file [directory] /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatchop"), + Unixsws => null, + Switches => Chop_Switches'Access, + Params => new Parameter_Array'(1 => File, 2 => Optional_File), + Defext => " "), + + Clean => + (Cname => new S'("CLEAN"), + Usage => new S'("GNAT CLEAN /qualifiers files"), + VMS_Only => False, + Unixcmd => new S'("gnatclean"), + Unixsws => null, + Switches => Clean_Switches'Access, + Params => new Parameter_Array'(1 => File), + Defext => " "), + + Compile => + (Cname => new S'("COMPILE"), + Usage => new S'("GNAT COMPILE filespec[,...] /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatmake"), + Unixsws => new Argument_List'(1 => new String'("-f"), + 2 => new String'("-u"), + 3 => new String'("-c")), + Switches => GCC_Switches'Access, + Params => new Parameter_Array'(1 => Files_Or_Wildcard), + Defext => " "), + + Elim => + (Cname => new S'("ELIM"), + Usage => new S'("GNAT ELIM name /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatelim"), + Unixsws => null, + Switches => Elim_Switches'Access, + Params => new Parameter_Array'(1 => Other_As_Is), + Defext => "ali"), + + Find => + (Cname => new S'("FIND"), + Usage => new S'("GNAT FIND pattern[:sourcefile[:line" + & "[:column]]] filespec[,...] /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatfind"), + Unixsws => null, + Switches => Find_Switches'Access, + Params => new Parameter_Array'(1 => Other_As_Is, + 2 => Files_Or_Wildcard), + Defext => "ali"), + + Krunch => + (Cname => new S'("KRUNCH"), + Usage => new S'("GNAT KRUNCH file [/COUNT=nnn]"), + VMS_Only => False, + Unixcmd => new S'("gnatkr"), + Unixsws => null, + Switches => Krunch_Switches'Access, + Params => new Parameter_Array'(1 => File), + Defext => " "), + + Library => + (Cname => new S'("LIBRARY"), + Usage => new S'("GNAT LIBRARY /[CREATE | SET | DELETE]" + & "=directory [/CONFIG=file]"), + VMS_Only => True, + Unixcmd => new S'("gnatlbr"), + Unixsws => null, + Switches => Lbr_Switches'Access, + Params => new Parameter_Array'(1 .. 0 => File), + Defext => " "), + + Link => + (Cname => new S'("LINK"), + Usage => new S'("GNAT LINK file[.ali]" + & " [extra obj_&_lib_&_exe_&_opt files]" + & " /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatlink"), + Unixsws => null, + Switches => Link_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => "ali"), + + List => + (Cname => new S'("LIST"), + Usage => new S'("GNAT LIST /qualifiers object_or_ali_file"), + VMS_Only => False, + Unixcmd => new S'("gnatls"), + Unixsws => null, + Switches => List_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => "ali"), + + Make => + (Cname => new S'("MAKE"), + Usage => new S'("GNAT MAKE file /qualifiers (includes " + & "COMPILE /qualifiers)"), + VMS_Only => False, + Unixcmd => new S'("gnatmake"), + Unixsws => null, + Switches => Make_Switches'Access, + Params => new Parameter_Array'(1 => File), + Defext => " "), + + Name => + (Cname => new S'("NAME"), + Usage => new S'("GNAT NAME /qualifiers naming-pattern " + & "[naming-patterns]"), + VMS_Only => False, + Unixcmd => new S'("gnatname"), + Unixsws => null, + Switches => Name_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_As_Is), + Defext => " "), + + Preprocess => + (Cname => new S'("PREPROCESS"), + Usage => + new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatprep"), + Unixsws => null, + Switches => Prep_Switches'Access, + Params => new Parameter_Array'(1 .. 3 => File), + Defext => " "), + + Pretty => + (Cname => new S'("PRETTY"), + Usage => new S'("GNAT PRETTY /qualifiers source_file"), + VMS_Only => False, + Unixcmd => new S'("gnatpp"), + Unixsws => null, + Switches => Pretty_Switches'Access, + Params => new Parameter_Array'(1 => File), + Defext => " "), + + Shared => + (Cname => new S'("SHARED"), + Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt" + & "files] /qualifiers"), + VMS_Only => True, + Unixcmd => new S'("gcc"), + Unixsws => + new Argument_List'(new String'("-shared") & Init_Object_Dirs), + Switches => Shared_Switches'Access, + Params => new Parameter_Array'(1 => Unlimited_Files), + Defext => " "), + + Standard => + (Cname => new S'("STANDARD"), + Usage => new S'("GNAT STANDARD"), + VMS_Only => False, + Unixcmd => new S'("gnatpsta"), + Unixsws => null, + Switches => Standard_Switches'Access, + Params => new Parameter_Array'(1 .. 0 => File), + Defext => " "), + + Stub => + (Cname => new S'("STUB"), + Usage => new S'("GNAT STUB file [directory]/qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatstub"), + Unixsws => null, + Switches => Stub_Switches'Access, + Params => new Parameter_Array'(1 => File, 2 => Optional_File), + Defext => " "), + + Xref => + (Cname => new S'("XREF"), + Usage => new S'("GNAT XREF filespec[,...] /qualifiers"), + VMS_Only => False, + Unixcmd => new S'("gnatxref"), + Unixsws => null, + Switches => Xref_Switches'Access, + Params => new Parameter_Array'(1 => Files_Or_Wildcard), + Defext => "ali") + ); + end Initialize; + + ------------------ + -- Invert_Sense -- + ------------------ + + function Invert_Sense (S : String) return VMS_Data.String_Ptr is + Sinv : String (1 .. S'Length * 2); + -- Result (for sure long enough) + + Sinvp : Natural := 0; + -- Pointer to output string + + begin + for Sp in S'Range loop + if Sp = S'First or else S (Sp - 1) = ',' then + if S (Sp) = '!' then + null; + else + Sinv (Sinvp + 1) := '!'; + Sinv (Sinvp + 2) := S (Sp); + Sinvp := Sinvp + 2; + end if; + + else + Sinv (Sinvp + 1) := S (Sp); + Sinvp := Sinvp + 1; + end if; + end loop; + + return new String'(Sinv (1 .. Sinvp)); + end Invert_Sense; + + ---------------------- + -- Is_Extensionless -- + ---------------------- + + function Is_Extensionless (F : String) return Boolean is + begin + for J in reverse F'Range loop + if F (J) = '.' then + return False; + elsif F (J) = '/' or else F (J) = ']' or else F (J) = ':' then + return True; + end if; + end loop; + + return True; + end Is_Extensionless; + + ----------- + -- Match -- + ----------- + + function Match (S1, S2 : String) return Boolean is + Dif : constant Integer := S2'First - S1'First; + + begin + + if S1'Length /= S2'Length then + return False; + + else + for J in S1'Range loop + if To_Lower (S1 (J)) /= To_Lower (S2 (J + Dif)) then + return False; + end if; + end loop; + + return True; + end if; + end Match; + + ------------------ + -- Match_Prefix -- + ------------------ + + function Match_Prefix (S1, S2 : String) return Boolean is + begin + if S1'Length > S2'Length then + return False; + else + return Match (S1, S2 (S2'First .. S2'First + S1'Length - 1)); + end if; + end Match_Prefix; + + ------------------- + -- Matching_Name -- + ------------------- + + function Matching_Name + (S : String; + Itm : Item_Ptr; + Quiet : Boolean := False) + return Item_Ptr + is + P1, P2 : Item_Ptr; + + procedure Err; + -- Little procedure to output command/qualifier/option as appropriate + -- and bump error count. + + --------- + -- Err -- + --------- + + procedure Err is + begin + if Quiet then + return; + end if; + + Errors := Errors + 1; + + if Itm /= null then + case Itm.Id is + when Id_Command => + Put (Standard_Error, "command"); + + when Id_Switch => + if Hostparm.OpenVMS then + Put (Standard_Error, "qualifier"); + else + Put (Standard_Error, "switch"); + end if; + + when Id_Option => + Put (Standard_Error, "option"); + + end case; + else + Put (Standard_Error, "input"); + + end if; + + Put (Standard_Error, ": "); + Put (Standard_Error, S); + end Err; + + -- Start of processing for Matching_Name + + begin + -- If exact match, that's the one we want + + P1 := Itm; + while P1 /= null loop + if Match (S, P1.Name.all) then + return P1; + else + P1 := P1.Next; + end if; + end loop; + + -- Now check for prefix matches + + P1 := Itm; + while P1 /= null loop + if P1.Name.all = "/<other>" then + return P1; + + elsif not Match_Prefix (S, P1.Name.all) then + P1 := P1.Next; + + else + -- Here we have found one matching prefix, so see if there is + -- another one (which is an ambiguity) + + P2 := P1.Next; + while P2 /= null loop + if Match_Prefix (S, P2.Name.all) then + if not Quiet then + Put (Standard_Error, "ambiguous "); + Err; + Put (Standard_Error, " (matches "); + Put (Standard_Error, P1.Name.all); + + while P2 /= null loop + if Match_Prefix (S, P2.Name.all) then + Put (Standard_Error, ','); + Put (Standard_Error, P2.Name.all); + end if; + + P2 := P2.Next; + end loop; + + Put_Line (Standard_Error, ")"); + end if; + + return null; + end if; + + P2 := P2.Next; + end loop; + + -- If we fall through that loop, then there was only one match + + return P1; + end if; + end loop; + + -- If we fall through outer loop, there was no match + + if not Quiet then + Put (Standard_Error, "unrecognized "); + Err; + New_Line (Standard_Error); + end if; + + return null; + end Matching_Name; + + ----------------------- + -- OK_Alphanumerplus -- + ----------------------- + + function OK_Alphanumerplus (S : String) return Boolean is + begin + if S'Length = 0 then + return False; + + else + for J in S'Range loop + if not (Is_Alphanumeric (S (J)) or else + S (J) = '_' or else S (J) = '$') + then + return False; + end if; + end loop; + + return True; + end if; + end OK_Alphanumerplus; + + ---------------- + -- OK_Integer -- + ---------------- + + function OK_Integer (S : String) return Boolean is + begin + if S'Length = 0 then + return False; + + else + for J in S'Range loop + if not Is_Digit (S (J)) then + return False; + end if; + end loop; + + return True; + end if; + end OK_Integer; + + -------------------- + -- Output_Version -- + -------------------- + + procedure Output_Version is + begin + Put ("GNAT "); + Put (Gnatvsn.Gnat_Version_String); + Put_Line (" Copyright 1996-2003 Free Software Foundation, Inc."); + end Output_Version; + + ----------- + -- Place -- + ----------- + + procedure Place (C : Character) is + begin + Buffer.Increment_Last; + Buffer.Table (Buffer.Last) := C; + end Place; + + procedure Place (S : String) is + begin + for J in S'Range loop + Place (S (J)); + end loop; + end Place; + + ----------------- + -- Place_Lower -- + ----------------- + + procedure Place_Lower (S : String) is + begin + for J in S'Range loop + Place (To_Lower (S (J))); + end loop; + end Place_Lower; + + ------------------------- + -- Place_Unix_Switches -- + ------------------------- + + procedure Place_Unix_Switches (S : VMS_Data.String_Ptr) is + P1, P2, P3 : Natural; + Remove : Boolean; + Slen, Sln2 : Natural; + Wild_Card : Boolean := False; + + begin + P1 := S'First; + while P1 <= S'Last loop + if S (P1) = '!' then + P1 := P1 + 1; + Remove := True; + else + Remove := False; + end if; + + P2 := P1; + pragma Assert (S (P1) = '-' or else S (P1) = '`'); + + while P2 < S'Last and then S (P2 + 1) /= ',' loop + P2 := P2 + 1; + end loop; + + -- Switch is now in S (P1 .. P2) + + Slen := P2 - P1 + 1; + + if Remove then + Wild_Card := S (P2) = '*'; + + if Wild_Card then + Slen := Slen - 1; + P2 := P2 - 1; + end if; + + P3 := 1; + while P3 <= Buffer.Last - Slen loop + if Buffer.Table (P3) = ' ' + and then String (Buffer.Table (P3 + 1 .. P3 + Slen)) = + S (P1 .. P2) + and then (Wild_Card + or else + P3 + Slen = Buffer.Last + or else + Buffer.Table (P3 + Slen + 1) = ' ') + then + Sln2 := Slen; + + if Wild_Card then + while P3 + Sln2 /= Buffer.Last + and then Buffer.Table (P3 + Sln2 + 1) /= ' ' + loop + Sln2 := Sln2 + 1; + end loop; + end if; + + Buffer.Table (P3 .. Buffer.Last - Sln2 - 1) := + Buffer.Table (P3 + Sln2 + 1 .. Buffer.Last); + Buffer.Set_Last (Buffer.Last - Sln2 - 1); + + else + P3 := P3 + 1; + end if; + end loop; + + if Wild_Card then + P2 := P2 + 1; + end if; + + else + pragma Assert (S (P2) /= '*'); + Place (' '); + + if S (P1) = '`' then + P1 := P1 + 1; + end if; + + Place (S (P1 .. P2)); + end if; + + P1 := P2 + 2; + end loop; + end Place_Unix_Switches; + + -------------------------------- + -- Validate_Command_Or_Option -- + -------------------------------- + + procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr) is + begin + pragma Assert (N'Length > 0); + + for J in N'Range loop + if N (J) = '_' then + pragma Assert (N (J - 1) /= '_'); + null; + else + pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J))); + null; + end if; + end loop; + end Validate_Command_Or_Option; + + -------------------------- + -- Validate_Unix_Switch -- + -------------------------- + + procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr) is + begin + if S (S'First) = '`' then + return; + end if; + + pragma Assert (S (S'First) = '-' or else S (S'First) = '!'); + + for J in S'First + 1 .. S'Last loop + pragma Assert (S (J) /= ' '); + + if S (J) = '!' then + pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-'); + null; + end if; + end loop; + end Validate_Unix_Switch; + + -------------------- + -- VMS_Conversion -- + -------------------- + + -- This function is *far* too long and *far* too heavily nested, it + -- needs procedural abstraction ??? + + procedure VMS_Conversion (The_Command : out Command_Type) is + begin + Buffer.Init; + + -- First we must preprocess the string form of the command and options + -- list into the internal form that we use. + + for C in Real_Command_Type loop + declare + Command : Item_Ptr := new Command_Item; + + Last_Switch : Item_Ptr; + -- Last switch in list + + begin + -- Link new command item into list of commands + + if Last_Command = null then + Commands := Command; + else + Last_Command.Next := Command; + end if; + + Last_Command := Command; + + -- Fill in fields of new command item + + Command.Name := Command_List (C).Cname; + Command.Usage := Command_List (C).Usage; + Command.Command := C; + + if Command_List (C).Unixsws = null then + Command.Unix_String := Command_List (C).Unixcmd; + else + declare + Cmd : String (1 .. 5_000); + Last : Natural := 0; + Sws : constant Argument_List_Access := + Command_List (C).Unixsws; + + begin + Cmd (1 .. Command_List (C).Unixcmd'Length) := + Command_List (C).Unixcmd.all; + Last := Command_List (C).Unixcmd'Length; + + for J in Sws'Range loop + Last := Last + 1; + Cmd (Last) := ' '; + Cmd (Last + 1 .. Last + Sws (J)'Length) := + Sws (J).all; + Last := Last + Sws (J)'Length; + end loop; + + Command.Unix_String := new String'(Cmd (1 .. Last)); + end; + end if; + + Command.Params := Command_List (C).Params; + Command.Defext := Command_List (C).Defext; + + Validate_Command_Or_Option (Command.Name); + + -- Process the switch list + + for S in Command_List (C).Switches'Range loop + declare + SS : constant VMS_Data.String_Ptr := + Command_List (C).Switches (S); + P : Natural := SS'First; + Sw : Item_Ptr := new Switch_Item; + + Last_Opt : Item_Ptr; + -- Pointer to last option + + begin + -- Link new switch item into list of switches + + if Last_Switch = null then + Command.Switches := Sw; + else + Last_Switch.Next := Sw; + end if; + + Last_Switch := Sw; + + -- Process switch string, first get name + + while SS (P) /= ' ' and SS (P) /= '=' loop + P := P + 1; + end loop; + + Sw.Name := new String'(SS (SS'First .. P - 1)); + + -- Direct translation case + + if SS (P) = ' ' then + Sw.Translation := T_Direct; + Sw.Unix_String := new String'(SS (P + 1 .. SS'Last)); + Validate_Unix_Switch (Sw.Unix_String); + + if SS (P - 1) = '>' then + Sw.Translation := T_Other; + + elsif SS (P + 1) = '`' then + null; + + -- Create the inverted case (/NO ..) + + elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then + Sw := new Switch_Item; + Last_Switch.Next := Sw; + Last_Switch := Sw; + + Sw.Name := + new String'("/NO" & SS (SS'First + 1 .. P - 1)); + Sw.Translation := T_Direct; + Sw.Unix_String := Invert_Sense (SS (P + 1 .. SS'Last)); + Validate_Unix_Switch (Sw.Unix_String); + end if; + + -- Directories translation case + + elsif SS (P + 1) = '*' then + pragma Assert (SS (SS'Last) = '*'); + Sw.Translation := T_Directories; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); + + -- Directory translation case + + elsif SS (P + 1) = '%' then + pragma Assert (SS (SS'Last) = '%'); + Sw.Translation := T_Directory; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); + + -- File translation case + + elsif SS (P + 1) = '@' then + pragma Assert (SS (SS'Last) = '@'); + Sw.Translation := T_File; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); + + -- No space file translation case + + elsif SS (P + 1) = '<' then + pragma Assert (SS (SS'Last) = '>'); + Sw.Translation := T_No_Space_File; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); + + -- Numeric translation case + + elsif SS (P + 1) = '#' then + pragma Assert (SS (SS'Last) = '#'); + Sw.Translation := T_Numeric; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); + + -- Alphanumerplus translation case + + elsif SS (P + 1) = '|' then + pragma Assert (SS (SS'Last) = '|'); + Sw.Translation := T_Alphanumplus; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); + + -- String translation case + + elsif SS (P + 1) = '"' then + pragma Assert (SS (SS'Last) = '"'); + Sw.Translation := T_String; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); + Validate_Unix_Switch (Sw.Unix_String); + + -- Commands translation case + + elsif SS (P + 1) = '?' then + Sw.Translation := T_Commands; + Sw.Unix_String := new String'(SS (P + 2 .. SS'Last)); + + -- Options translation case + + else + Sw.Translation := T_Options; + Sw.Unix_String := new String'(""); + + P := P + 1; -- bump past = + while P <= SS'Last loop + declare + Opt : Item_Ptr := new Option_Item; + Q : Natural; + begin + -- Link new option item into options list + + if Last_Opt = null then + Sw.Options := Opt; + else + Last_Opt.Next := Opt; + end if; + + Last_Opt := Opt; + + -- Fill in fields of new option item + + Q := P; + while SS (Q) /= ' ' loop + Q := Q + 1; + end loop; + + Opt.Name := new String'(SS (P .. Q - 1)); + Validate_Command_Or_Option (Opt.Name); + + P := Q + 1; + Q := P; + + while Q <= SS'Last and then SS (Q) /= ' ' loop + Q := Q + 1; + end loop; + + Opt.Unix_String := new String'(SS (P .. Q - 1)); + Validate_Unix_Switch (Opt.Unix_String); + P := Q + 1; + end; + end loop; + end if; + end; + end loop; + end; + end loop; + + -- If no parameters, give complete list of commands + + if Argument_Count = 0 then + Output_Version; + New_Line; + Put_Line ("List of available commands"); + New_Line; + + while Commands /= null loop + Put (Commands.Usage.all); + Set_Col (53); + Put_Line (Commands.Unix_String.all); + Commands := Commands.Next; + end loop; + + raise Normal_Exit; + end if; + + Arg_Num := 1; + + -- Loop through arguments + + while Arg_Num <= Argument_Count loop + + Process_Argument : declare + Argv : String_Access; + Arg_Idx : Integer; + + function Get_Arg_End + (Argv : String; + Arg_Idx : Integer) + return Integer; + -- Begins looking at Arg_Idx + 1 and returns the index of the + -- last character before a slash or else the index of the last + -- character in the string Argv. + + ----------------- + -- Get_Arg_End -- + ----------------- + + function Get_Arg_End + (Argv : String; + Arg_Idx : Integer) + return Integer + is + begin + for J in Arg_Idx + 1 .. Argv'Last loop + if Argv (J) = '/' then + return J - 1; + end if; + end loop; + + return Argv'Last; + end Get_Arg_End; + + -- Start of processing for Process_Argument + + begin + Argv := new String'(Argument (Arg_Num)); + Arg_Idx := Argv'First; + + <<Tryagain_After_Coalesce>> + loop + declare + Next_Arg_Idx : Integer; + Arg : String_Access; + + begin + Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); + Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx)); + + -- The first one must be a command name + + if Arg_Num = 1 and then Arg_Idx = Argv'First then + + Command := Matching_Name (Arg.all, Commands); + + if Command = null then + raise Error_Exit; + end if; + + The_Command := Command.Command; + + -- Give usage information if only command given + + if Argument_Count = 1 and then Next_Arg_Idx = Argv'Last + and then Command.Command /= VMS_Conv.Standard + then + Output_Version; + New_Line; + Put_Line + ("List of available qualifiers and options"); + New_Line; + + Put (Command.Usage.all); + Set_Col (53); + Put_Line (Command.Unix_String.all); + + declare + Sw : Item_Ptr := Command.Switches; + + begin + while Sw /= null loop + Put (" "); + Put (Sw.Name.all); + + case Sw.Translation is + + when T_Other => + Set_Col (53); + Put_Line (Sw.Unix_String.all & + "/<other>"); + + when T_Direct => + Set_Col (53); + Put_Line (Sw.Unix_String.all); + + when T_Directories => + Put ("=(direc,direc,..direc)"); + Set_Col (53); + Put (Sw.Unix_String.all); + Put (" direc "); + Put (Sw.Unix_String.all); + Put_Line (" direc ..."); + + when T_Directory => + Put ("=directory"); + Set_Col (53); + Put (Sw.Unix_String.all); + + if Sw.Unix_String (Sw.Unix_String'Last) + /= '=' + then + Put (' '); + end if; + + Put_Line ("directory "); + + when T_File | T_No_Space_File => + Put ("=file"); + Set_Col (53); + Put (Sw.Unix_String.all); + + if Sw.Translation = T_File + and then Sw.Unix_String + (Sw.Unix_String'Last) + /= '=' + then + Put (' '); + end if; + + Put_Line ("file "); + + when T_Numeric => + Put ("=nnn"); + Set_Col (53); + + if Sw.Unix_String (Sw.Unix_String'First) + = '`' + then + Put (Sw.Unix_String + (Sw.Unix_String'First + 1 + .. Sw.Unix_String'Last)); + else + Put (Sw.Unix_String.all); + end if; + + Put_Line ("nnn"); + + when T_Alphanumplus => + Put ("=xyz"); + Set_Col (53); + + if Sw.Unix_String (Sw.Unix_String'First) + = '`' + then + Put (Sw.Unix_String + (Sw.Unix_String'First + 1 + .. Sw.Unix_String'Last)); + else + Put (Sw.Unix_String.all); + end if; + + Put_Line ("xyz"); + + when T_String => + Put ("="); + Put ('"'); + Put ("<string>"); + Put ('"'); + Set_Col (53); + + Put (Sw.Unix_String.all); + + if Sw.Unix_String (Sw.Unix_String'Last) + /= '=' + then + Put (' '); + end if; + + Put ("<string>"); + New_Line; + + when T_Commands => + Put (" (switches for "); + Put (Sw.Unix_String + (Sw.Unix_String'First + 7 + .. Sw.Unix_String'Last)); + Put (')'); + Set_Col (53); + Put (Sw.Unix_String + (Sw.Unix_String'First + .. Sw.Unix_String'First + 5)); + Put_Line (" switches"); + + when T_Options => + declare + Opt : Item_Ptr := Sw.Options; + + begin + Put_Line ("=(option,option..)"); + + while Opt /= null loop + Put (" "); + Put (Opt.Name.all); + + if Opt = Sw.Options then + Put (" (D)"); + end if; + + Set_Col (53); + Put_Line (Opt.Unix_String.all); + Opt := Opt.Next; + end loop; + end; + + end case; + + Sw := Sw.Next; + end loop; + end; + + raise Normal_Exit; + end if; + + -- Special handling for internal debugging switch /? + + elsif Arg.all = "/?" then + Display_Command := True; + + -- Copy -switch unchanged + + elsif Arg (Arg'First) = '-' then + Place (' '); + Place (Arg.all); + + -- Copy quoted switch with quotes stripped + + elsif Arg (Arg'First) = '"' then + if Arg (Arg'Last) /= '"' then + Put (Standard_Error, "misquoted argument: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + + else + Place (' '); + Place (Arg (Arg'First + 1 .. Arg'Last - 1)); + end if; + + -- Parameter Argument + + elsif Arg (Arg'First) /= '/' + and then Make_Commands_Active = null + then + Param_Count := Param_Count + 1; + + if Param_Count <= Command.Params'Length then + + case Command.Params (Param_Count) is + + when File | Optional_File => + declare + Normal_File : constant String_Access := + To_Canonical_File_Spec + (Arg.all); + + begin + Place (' '); + Place_Lower (Normal_File.all); + + if Is_Extensionless (Normal_File.all) + and then Command.Defext /= " " + then + Place ('.'); + Place (Command.Defext); + end if; + end; + + when Unlimited_Files => + declare + Normal_File : + constant String_Access := + To_Canonical_File_Spec (Arg.all); + + File_Is_Wild : Boolean := False; + File_List : String_Access_List_Access; + + begin + for J in Arg'Range loop + if Arg (J) = '*' + or else Arg (J) = '%' + then + File_Is_Wild := True; + end if; + end loop; + + if File_Is_Wild then + File_List := To_Canonical_File_List + (Arg.all, False); + + for J in File_List.all'Range loop + Place (' '); + Place_Lower (File_List.all (J).all); + end loop; + + else + Place (' '); + Place_Lower (Normal_File.all); + + if Is_Extensionless (Normal_File.all) + and then Command.Defext /= " " + then + Place ('.'); + Place (Command.Defext); + end if; + end if; + + Param_Count := Param_Count - 1; + end; + + when Other_As_Is => + Place (' '); + Place (Arg.all); + + when Unlimited_As_Is => + Place (' '); + Place (Arg.all); + Param_Count := Param_Count - 1; + + when Files_Or_Wildcard => + + -- Remove spaces from a comma separated list + -- of file names and adjust control variables + -- accordingly. + + while Arg_Num < Argument_Count and then + (Argv (Argv'Last) = ',' xor + Argument (Arg_Num + 1) + (Argument (Arg_Num + 1)'First) = ',') + loop + Argv := new String' + (Argv.all & Argument (Arg_Num + 1)); + Arg_Num := Arg_Num + 1; + Arg_Idx := Argv'First; + Next_Arg_Idx := + Get_Arg_End (Argv.all, Arg_Idx); + Arg := new String' + (Argv (Arg_Idx .. Next_Arg_Idx)); + end loop; + + -- Parse the comma separated list of VMS + -- filenames and place them on the command + -- line as space separated Unix style + -- filenames. Lower case and add default + -- extension as appropriate. + + declare + Arg1_Idx : Integer := Arg'First; + + function Get_Arg1_End + (Arg : String; Arg_Idx : Integer) + return Integer; + -- Begins looking at Arg_Idx + 1 and + -- returns the index of the last character + -- before a comma or else the index of the + -- last character in the string Arg. + + ------------------ + -- Get_Arg1_End -- + ------------------ + + function Get_Arg1_End + (Arg : String; Arg_Idx : Integer) + return Integer + is + begin + for J in Arg_Idx + 1 .. Arg'Last loop + if Arg (J) = ',' then + return J - 1; + end if; + end loop; + + return Arg'Last; + end Get_Arg1_End; + + begin + loop + declare + Next_Arg1_Idx : + constant Integer := + Get_Arg1_End (Arg.all, Arg1_Idx); + + Arg1 : + constant String := + Arg (Arg1_Idx .. Next_Arg1_Idx); + + Normal_File : + constant String_Access := + To_Canonical_File_Spec (Arg1); + + begin + Place (' '); + Place_Lower (Normal_File.all); + + if Is_Extensionless (Normal_File.all) + and then Command.Defext /= " " + then + Place ('.'); + Place (Command.Defext); + end if; + + Arg1_Idx := Next_Arg1_Idx + 1; + end; + + exit when Arg1_Idx > Arg'Last; + + -- Don't allow two or more commas in + -- a row + + if Arg (Arg1_Idx) = ',' then + Arg1_Idx := Arg1_Idx + 1; + if Arg1_Idx > Arg'Last or else + Arg (Arg1_Idx) = ',' + then + Put_Line + (Standard_Error, + "Malformed Parameter: " & + Arg.all); + Put (Standard_Error, "usage: "); + Put_Line (Standard_Error, + Command.Usage.all); + raise Error_Exit; + end if; + end if; + + end loop; + end; + end case; + end if; + + -- Qualifier argument + + else + -- This code is too heavily nested, should be + -- separated out as separate subprogram ??? + + declare + Sw : Item_Ptr; + SwP : Natural; + P2 : Natural; + Endp : Natural := 0; -- avoid warning! + Opt : Item_Ptr; + + begin + SwP := Arg'First; + while SwP < Arg'Last + and then Arg (SwP + 1) /= '=' + loop + SwP := SwP + 1; + end loop; + + -- At this point, the switch name is in + -- Arg (Arg'First..SwP) and if that is not the + -- whole switch, then there is an equal sign at + -- Arg (SwP + 1) and the rest of Arg is what comes + -- after the equal sign. + + -- If make commands are active, see if we have + -- another COMMANDS_TRANSLATION switch belonging + -- to gnatmake. + + if Make_Commands_Active /= null then + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Command.Switches, + Quiet => True); + + if Sw /= null + and then Sw.Translation = T_Commands + then + null; + + else + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Make_Commands_Active.Switches, + Quiet => False); + end if; + + -- For case of GNAT MAKE or CHOP, if we cannot + -- find the switch, then see if it is a + -- recognized compiler switch instead, and if + -- so process the compiler switch. + + elsif Command.Name.all = "MAKE" + or else Command.Name.all = "CHOP" then + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Command.Switches, + Quiet => True); + + if Sw = null then + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Matching_Name + ("COMPILE", Commands).Switches, + Quiet => False); + end if; + + -- For all other cases, just search the relevant + -- command. + + else + Sw := + Matching_Name + (Arg (Arg'First .. SwP), + Command.Switches, + Quiet => False); + end if; + + if Sw /= null then + case Sw.Translation is + + when T_Direct => + Place_Unix_Switches (Sw.Unix_String); + if SwP < Arg'Last + and then Arg (SwP + 1) = '=' + then + Put (Standard_Error, + "qualifier options ignored: "); + Put_Line (Standard_Error, Arg.all); + end if; + + when T_Directories => + if SwP + 1 > Arg'Last then + Put (Standard_Error, + "missing directories for: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + + elsif Arg (SwP + 2) /= '(' then + SwP := SwP + 2; + Endp := Arg'Last; + + elsif Arg (Arg'Last) /= ')' then + + -- Remove spaces from a comma separated + -- list of file names and adjust + -- control variables accordingly. + + if Arg_Num < Argument_Count and then + (Argv (Argv'Last) = ',' xor + Argument (Arg_Num + 1) + (Argument (Arg_Num + 1)'First) = ',') + then + Argv := + new String'(Argv.all + & Argument + (Arg_Num + 1)); + Arg_Num := Arg_Num + 1; + Arg_Idx := Argv'First; + Next_Arg_Idx + := Get_Arg_End (Argv.all, Arg_Idx); + Arg := new String' + (Argv (Arg_Idx .. Next_Arg_Idx)); + goto Tryagain_After_Coalesce; + end if; + + Put (Standard_Error, + "incorrectly parenthesized " & + "or malformed argument: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + + else + SwP := SwP + 3; + Endp := Arg'Last - 1; + end if; + + while SwP <= Endp loop + declare + Dir_Is_Wild : Boolean := False; + Dir_Maybe_Is_Wild : Boolean := False; + Dir_List : String_Access_List_Access; + begin + P2 := SwP; + + while P2 < Endp + and then Arg (P2 + 1) /= ',' + loop + + -- A wildcard directory spec on + -- VMS will contain either * or + -- % or ... + + if Arg (P2) = '*' then + Dir_Is_Wild := True; + + elsif Arg (P2) = '%' then + Dir_Is_Wild := True; + + elsif Dir_Maybe_Is_Wild + and then Arg (P2) = '.' + and then Arg (P2 + 1) = '.' + then + Dir_Is_Wild := True; + Dir_Maybe_Is_Wild := False; + + elsif Dir_Maybe_Is_Wild then + Dir_Maybe_Is_Wild := False; + + elsif Arg (P2) = '.' + and then Arg (P2 + 1) = '.' + then + Dir_Maybe_Is_Wild := True; + + end if; + + P2 := P2 + 1; + end loop; + + if Dir_Is_Wild then + Dir_List := To_Canonical_File_List + (Arg (SwP .. P2), True); + + for J in Dir_List.all'Range loop + Place_Unix_Switches + (Sw.Unix_String); + Place_Lower + (Dir_List.all (J).all); + end loop; + + else + Place_Unix_Switches + (Sw.Unix_String); + Place_Lower + (To_Canonical_Dir_Spec + (Arg (SwP .. P2), False).all); + end if; + + SwP := P2 + 2; + end; + end loop; + + when T_Directory => + if SwP + 1 > Arg'Last then + Put (Standard_Error, + "missing directory for: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + + else + Place_Unix_Switches (Sw.Unix_String); + + -- Some switches end in "=". No space + -- here + + if Sw.Unix_String + (Sw.Unix_String'Last) /= '=' + then + Place (' '); + end if; + + Place_Lower + (To_Canonical_Dir_Spec + (Arg (SwP + 2 .. Arg'Last), + False).all); + end if; + + when T_File | T_No_Space_File => + if SwP + 1 > Arg'Last then + Put (Standard_Error, + "missing file for: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + + else + Place_Unix_Switches (Sw.Unix_String); + + -- Some switches end in "=". No space + -- here. + + if Sw.Translation = T_File + and then Sw.Unix_String + (Sw.Unix_String'Last) /= '=' + then + Place (' '); + end if; + + Place_Lower + (To_Canonical_File_Spec + (Arg (SwP + 2 .. Arg'Last)).all); + end if; + + when T_Numeric => + if + OK_Integer (Arg (SwP + 2 .. Arg'Last)) + then + Place_Unix_Switches (Sw.Unix_String); + Place (Arg (SwP + 2 .. Arg'Last)); + + else + Put (Standard_Error, "argument for "); + Put (Standard_Error, Sw.Name.all); + Put_Line + (Standard_Error, " must be numeric"); + Errors := Errors + 1; + end if; + + when T_Alphanumplus => + if + OK_Alphanumerplus + (Arg (SwP + 2 .. Arg'Last)) + then + Place_Unix_Switches (Sw.Unix_String); + Place (Arg (SwP + 2 .. Arg'Last)); + + else + Put (Standard_Error, "argument for "); + Put (Standard_Error, Sw.Name.all); + Put_Line (Standard_Error, + " must be alphanumeric"); + Errors := Errors + 1; + end if; + + when T_String => + + -- A String value must be extended to the + -- end of the Argv, otherwise strings like + -- "foo/bar" get split at the slash. + -- + -- The begining and ending of the string + -- are flagged with embedded nulls which + -- are removed when building the Spawn + -- call. Nulls are use because they won't + -- show up in a /? output. Quotes aren't + -- used because that would make it + -- difficult to embed them. + + Place_Unix_Switches (Sw.Unix_String); + if Next_Arg_Idx /= Argv'Last then + Next_Arg_Idx := Argv'Last; + Arg := new String' + (Argv (Arg_Idx .. Next_Arg_Idx)); + + SwP := Arg'First; + while SwP < Arg'Last and then + Arg (SwP + 1) /= '=' loop + SwP := SwP + 1; + end loop; + end if; + Place (ASCII.NUL); + Place (Arg (SwP + 2 .. Arg'Last)); + Place (ASCII.NUL); + + when T_Commands => + + -- Output -largs/-bargs/-cargs + + Place (' '); + Place (Sw.Unix_String + (Sw.Unix_String'First .. + Sw.Unix_String'First + 5)); + + if Sw.Unix_String + (Sw.Unix_String'First + 7 .. + Sw.Unix_String'Last) = + "MAKE" + then + Make_Commands_Active := null; + + else + -- Set source of new commands, also + -- setting this non-null indicates that + -- we are in the special commands mode + -- for processing the -xargs case. + + Make_Commands_Active := + Matching_Name + (Sw.Unix_String + (Sw.Unix_String'First + 7 .. + Sw.Unix_String'Last), + Commands); + end if; + + when T_Options => + if SwP + 1 > Arg'Last then + Place_Unix_Switches + (Sw.Options.Unix_String); + SwP := Endp + 1; + + elsif Arg (SwP + 2) /= '(' then + SwP := SwP + 2; + Endp := Arg'Last; + + elsif Arg (Arg'Last) /= ')' then + Put + (Standard_Error, + "incorrectly parenthesized " & + "argument: "); + Put_Line (Standard_Error, Arg.all); + Errors := Errors + 1; + SwP := Endp + 1; + + else + SwP := SwP + 3; + Endp := Arg'Last - 1; + end if; + + while SwP <= Endp loop + P2 := SwP; + + while P2 < Endp + and then Arg (P2 + 1) /= ',' + loop + P2 := P2 + 1; + end loop; + + -- Option name is in Arg (SwP .. P2) + + Opt := Matching_Name (Arg (SwP .. P2), + Sw.Options); + + if Opt /= null then + Place_Unix_Switches + (Opt.Unix_String); + end if; + + SwP := P2 + 2; + end loop; + + when T_Other => + Place_Unix_Switches + (new String'(Sw.Unix_String.all & + Arg.all)); + + end case; + end if; + end; + end if; + + Arg_Idx := Next_Arg_Idx + 1; + end; + + exit when Arg_Idx > Argv'Last; + + end loop; + end Process_Argument; + + Arg_Num := Arg_Num + 1; + end loop; + + -- Gross error checking that the number of parameters is correct. + -- Not applicable to Unlimited_Files parameters. + + if (Param_Count = Command.Params'Length - 1 + and then Command.Params (Param_Count + 1) = Unlimited_Files) + or else Param_Count <= Command.Params'Length + then + null; + + else + Put_Line (Standard_Error, + "Parameter count of " + & Integer'Image (Param_Count) + & " not equal to expected " + & Integer'Image (Command.Params'Length)); + Put (Standard_Error, "usage: "); + Put_Line (Standard_Error, Command.Usage.all); + Errors := Errors + 1; + end if; + + if Errors > 0 then + raise Error_Exit; + else + -- Prepare arguments for a call to spawn, filtering out + -- embedded nulls place there to delineate strings. + + declare + P1, P2 : Natural; + Inside_Nul : Boolean := False; + Arg : String (1 .. 1024); + Arg_Ctr : Natural; + + begin + P1 := 1; + + while P1 <= Buffer.Last and then Buffer.Table (P1) = ' ' loop + P1 := P1 + 1; + end loop; + + Arg_Ctr := 1; + Arg (Arg_Ctr) := Buffer.Table (P1); + + while P1 <= Buffer.Last loop + + if Buffer.Table (P1) = ASCII.NUL then + if Inside_Nul then + Inside_Nul := False; + else + Inside_Nul := True; + end if; + end if; + + if Buffer.Table (P1) = ' ' and then not Inside_Nul then + P1 := P1 + 1; + Arg_Ctr := Arg_Ctr + 1; + Arg (Arg_Ctr) := Buffer.Table (P1); + + else + Last_Switches.Increment_Last; + P2 := P1; + + while P2 < Buffer.Last + and then (Buffer.Table (P2 + 1) /= ' ' or else + Inside_Nul) + loop + P2 := P2 + 1; + Arg_Ctr := Arg_Ctr + 1; + Arg (Arg_Ctr) := Buffer.Table (P2); + if Buffer.Table (P2) = ASCII.NUL then + Arg_Ctr := Arg_Ctr - 1; + if Inside_Nul then + Inside_Nul := False; + else + Inside_Nul := True; + end if; + end if; + end loop; + + Last_Switches.Table (Last_Switches.Last) := + new String'(String (Arg (1 .. Arg_Ctr))); + P1 := P2 + 2; + Arg_Ctr := 1; + Arg (Arg_Ctr) := Buffer.Table (P1); + end if; + end loop; + end; + end if; + end VMS_Conversion; + +end VMS_Conv; |