procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

3psoccon.ads, [...]: Files added.

Browse source 
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
This commit is contained in:
Arnaud Charlet 2003-10-21 15:42:24 +02:00 • committed by Arnaud Charlet
parent 75a5a481c2
commit fbf5a39b3e
987 changed files with 134922 additions and 55139 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
gcc/ada/1ic.ads
View file

@ -1,4 +1,4 @@
-----------------------------------------------------------------------------
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --

171
gcc/ada/31soccon.ads
View file

@ -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
--------------
-- Families --
--------------
AF_INET : constant := 2;
AF_INET6 : constant := 27;
AF_INET : constant := 2; -- IPv4 address family
AF_INET6 : constant := 27; -- IPv6 address family
-- Modes
-----------
-- Modes --
-----------
SOCK_STREAM : constant := 2;
SOCK_DGRAM : constant := 1;
SOCK_STREAM : constant := 2; -- Stream socket
SOCK_DGRAM : constant := 1; -- Datagram socket
-- Socket Errors
-------------------
-- 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;
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 errors --
-----------------
HOST_NOT_FOUND : constant := 1;
TRY_AGAIN : constant := 2;
NO_ADDRESS : constant := 4;
NO_RECOVERY : constant := 3;
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
-------------------
-- Control flags --
-------------------
FIONBIO : constant := -2147195266;
FIONREAD : constant := 1074030207;
FIONBIO : constant := -2147195266; -- Set/clear non-blocking io
FIONREAD : constant := 1074030207; -- How many bytes to read
-- Shutdown Modes
--------------------
-- Shutdown modes --
--------------------
SHUT_RD : constant := 0;
SHUT_WR : constant := 1;
SHUT_RDWR : constant := 2;
SHUT_RD : constant := 0; -- No more recv
SHUT_WR : constant := 1; -- No more send
SHUT_RDWR : constant := 2; -- No more recv/send
-- Protocol Levels
---------------------
-- Protocol levels --
---------------------
SOL_SOCKET : constant := 65535;
IPPROTO_IP : constant := 0;
IPPROTO_UDP : constant := 17;
IPPROTO_TCP : constant := 6;
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
-- Socket Options
-------------------
-- 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
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;
end GNAT.Sockets.Constants;

15
gcc/ada/31soliop.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------
-- 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
package GNAT.Sockets.Linker_Options is
-- This is the UnixWare version of this package.
private
pragma Linker_Options ("-lnsl");
pragma Linker_Options ("-lsocket");
end GNAT.Sockets.Linker_Options;

171
gcc/ada/3asoccon.ads
View file

@ -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
--------------
-- Families --
--------------
AF_INET : constant := 2;
AF_INET6 : constant := 26;
AF_INET : constant := 2; -- IPv4 address family
AF_INET6 : constant := 26; -- IPv6 address family
-- Modes
-----------
-- Modes --
-----------
SOCK_STREAM : constant := 1;
SOCK_DGRAM : constant := 2;
SOCK_STREAM : constant := 1; -- Stream socket
SOCK_DGRAM : constant := 2; -- Datagram socket
-- Socket Errors
-------------------
-- 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;
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 errors --
-----------------
HOST_NOT_FOUND : constant := 1;
TRY_AGAIN : constant := 2;
NO_ADDRESS : constant := 4;
NO_RECOVERY : constant := 3;
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
-------------------
-- Control flags --
-------------------
FIONBIO : constant := -2147195266;
FIONREAD : constant := 1074030207;
FIONBIO : constant := -2147195266; -- Set/clear non-blocking io
FIONREAD : constant := 1074030207; -- How many bytes to read
-- Shutdown Modes
--------------------
-- Shutdown modes --
--------------------
SHUT_RD : constant := 0;
SHUT_WR : constant := 1;
SHUT_RDWR : constant := 2;
SHUT_RD : constant := 0; -- No more recv
SHUT_WR : constant := 1; -- No more send
SHUT_RDWR : constant := 2; -- No more recv/send
-- Protocol Levels
---------------------
-- Protocol levels --
---------------------
SOL_SOCKET : constant := 65535;
IPPROTO_IP : constant := 0;
IPPROTO_UDP : constant := 17;
IPPROTO_TCP : constant := 6;
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
-- Socket Options
-------------------
-- 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
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;
end GNAT.Sockets.Constants;

171
gcc/ada/3bsoccon.ads
View file

@ -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
--------------
-- Families --
--------------
AF_INET : constant := 2;
AF_INET6 : constant := 24;
AF_INET : constant := 2; -- IPv4 address family
AF_INET6 : constant := 24; -- IPv6 address family
-- Modes
-----------
-- Modes --
-----------
SOCK_STREAM : constant := 1;
SOCK_DGRAM : constant := 2;
SOCK_STREAM : constant := 1; -- Stream socket
SOCK_DGRAM : constant := 2; -- Datagram socket
-- Socket Errors
-------------------
-- 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;
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 errors --
-----------------
HOST_NOT_FOUND : constant := 1;
TRY_AGAIN : constant := 2;
NO_ADDRESS : constant := 4;
NO_RECOVERY : constant := 3;
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
-------------------
-- Control flags --
-------------------
FIONBIO : constant := -2147195266;
FIONREAD : constant := 1074030207;
FIONBIO : constant := -2147195266; -- Set/clear non-blocking io
FIONREAD : constant := 1074030207; -- How many bytes to read
-- Shutdown Modes
--------------------
-- Shutdown modes --
--------------------
SHUT_RD : constant := 0;
SHUT_WR : constant := 1;
SHUT_RDWR : constant := 2;
SHUT_RD : constant := 0; -- No more recv
SHUT_WR : constant := 1; -- No more send
SHUT_RDWR : constant := 2; -- No more recv/send
-- Protocol Levels
---------------------
-- Protocol levels --
---------------------
SOL_SOCKET : constant := 65535;
IPPROTO_IP : constant := 0;
IPPROTO_UDP : constant := 17;
IPPROTO_TCP : constant := 6;
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
-- Socket Options
-------------------
-- 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
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;
end GNAT.Sockets.Constants;

171
gcc/ada/3gsoccon.ads
View file

@ -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
--------------
-- Families --
--------------
AF_INET : constant := 2;
AF_INET6 : constant := 24;
AF_INET : constant := 2; -- IPv4 address family
AF_INET6 : constant := 24; -- IPv6 address family
-- Modes
-----------
-- Modes --
-----------
SOCK_STREAM : constant := 2;
SOCK_DGRAM : constant := 1;
SOCK_STREAM : constant := 2; -- Stream socket
SOCK_DGRAM : constant := 1; -- Datagram socket
-- Socket Errors
-------------------
-- 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;
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 errors --
-----------------
HOST_NOT_FOUND : constant := 1;
TRY_AGAIN : constant := 2;
NO_ADDRESS : constant := 4;
NO_RECOVERY : constant := 3;
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
-------------------
-- Control flags --
-------------------
FIONBIO : constant := -2147195266;
FIONREAD : constant := 1074030207;
FIONBIO : constant := -2147195266; -- Set/clear non-blocking io
FIONREAD : constant := 1074030207; -- How many bytes to read
-- Shutdown Modes
--------------------
-- Shutdown modes --
--------------------
SHUT_RD : constant := 0;
SHUT_WR : constant := 1;
SHUT_RDWR : constant := 2;
SHUT_RD : constant := 0; -- No more recv
SHUT_WR : constant := 1; -- No more send
SHUT_RDWR : constant := 2; -- No more recv/send
-- Protocol Levels
---------------------
-- Protocol levels --
---------------------
SOL_SOCKET : constant := 65535;
IPPROTO_IP : constant := 0;
IPPROTO_UDP : constant := 17;
IPPROTO_TCP : constant := 6;
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
-- Socket Options
-------------------
-- 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
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;
end GNAT.Sockets.Constants;

171
gcc/ada/3hsoccon.ads
View file

@ -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
--------------
-- Families --
--------------
AF_INET : constant := 2;
AF_INET6 : constant := -1;
AF_INET : constant := 2; -- IPv4 address family
AF_INET6 : constant := 26; -- IPv6 address family
-- Modes
-----------
-- Modes --
-----------
SOCK_STREAM : constant := 1;
SOCK_DGRAM : constant := 2;
SOCK_STREAM : constant := 1; -- Stream socket
SOCK_DGRAM : constant := 2; -- Datagram socket
-- Socket Errors
-------------------
-- 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;
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 errors --
-----------------
HOST_NOT_FOUND : constant := 1;
TRY_AGAIN : constant := 2;
NO_ADDRESS : constant := 4;
NO_RECOVERY : constant := 3;
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
-------------------
-- Control flags --
-------------------
FIONBIO : constant := -2147195266;
FIONREAD : constant := 1074030207;
FIONBIO : constant := -2147195266; -- Set/clear non-blocking io
FIONREAD : constant := 1074030207; -- How many bytes to read
-- Shutdown Modes
--------------------
-- Shutdown modes --
--------------------
SHUT_RD : constant := 0;
SHUT_WR : constant := 1;
SHUT_RDWR : constant := 2;
SHUT_RD : constant := 0; -- No more recv
SHUT_WR : constant := 1; -- No more send
SHUT_RDWR : constant := 2; -- No more recv/send
-- Protocol Levels
---------------------
-- Protocol levels --
---------------------
SOL_SOCKET : constant := 65535;
IPPROTO_IP : constant := 0;
IPPROTO_UDP : constant := 17;
IPPROTO_TCP : constant := 6;
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
-- Socket Options
-------------------
-- 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
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;
end GNAT.Sockets.Constants;

158
gcc/ada/3psoccon.ads Normal file
View file

@ -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;

171
gcc/ada/3ssoccon.ads
View file

@ -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
--------------
-- Families --
--------------
AF_INET : constant := 2;
AF_INET6 : constant := 26;
AF_INET : constant := 2; -- IPv4 address family
AF_INET6 : constant := 26; -- IPv6 address family
-- Modes
-----------
-- Modes --
-----------
SOCK_STREAM : constant := 2;
SOCK_DGRAM : constant := 1;
SOCK_STREAM : constant := 2; -- Stream socket
SOCK_DGRAM : constant := 1; -- Datagram socket
-- Socket Errors
-------------------
-- 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;
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 errors --
-----------------
HOST_NOT_FOUND : constant := 1;
TRY_AGAIN : constant := 2;
NO_ADDRESS : constant := 4;
NO_RECOVERY : constant := 3;
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
-------------------
-- Control flags --
-------------------
FIONBIO : constant := -2147195266;
FIONREAD : constant := 1074030207;
FIONBIO : constant := -2147195266; -- Set/clear non-blocking io
FIONREAD : constant := 1074030207; -- How many bytes to read
-- Shutdown Modes
--------------------
-- Shutdown modes --
--------------------
SHUT_RD : constant := 0;
SHUT_WR : constant := 1;
SHUT_RDWR : constant := 2;
SHUT_RD : constant := 0; -- No more recv
SHUT_WR : constant := 1; -- No more send
SHUT_RDWR : constant := 2; -- No more recv/send
-- Protocol Levels
---------------------
-- Protocol levels --
---------------------
SOL_SOCKET : constant := 65535;
IPPROTO_IP : constant := 0;
IPPROTO_UDP : constant := 17;
IPPROTO_TCP : constant := 6;
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
-- Socket Options
-------------------
-- 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
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;
end GNAT.Sockets.Constants;

15
gcc/ada/3ssoliop.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------
-- 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
package GNAT.Sockets.Linker_Options is
-- This is the Solaris version of this package.
private
pragma Linker_Options ("-lnsl");
pragma Linker_Options ("-lsocket");
end GNAT.Sockets.Linker_Options;

73
gcc/ada/3veacodu.adb Normal file
View file

@ -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;

1187
gcc/ada/3vexpect.adb Normal file
View file

File diff suppressed because it is too large Load diff

158
gcc/ada/3vsoccon.ads Normal file
View file

@ -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;

577
gcc/ada/3vsocthi.adb Normal file
View file

@ -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;

445
gcc/ada/3vsocthi.ads Normal file
View file

@ -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;

185
gcc/ada/3vtrasym.adb Normal file
View file

@ -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;

188
gcc/ada/3wsoccon.ads
View file

@ -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
--------------
-- Families --
--------------
AF_INET : constant := 2;
AF_INET6 : constant := 3;
AF_INET : constant := 2; -- IPv4 address family
AF_INET6 : constant := 3; -- IPv6 address family
-- Modes
-----------
-- Modes --
-----------
SOCK_STREAM : constant := 1;
SOCK_DGRAM : constant := 2;
SOCK_STREAM : constant := 1; -- Stream socket
SOCK_DGRAM : constant := 2; -- Datagram socket
-- Socket Errors
-------------------
-- 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;
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 errors --
-----------------
HOST_NOT_FOUND : constant := 11001;
TRY_AGAIN : constant := 11002;
NO_RECOVERY : constant := 11003;
NO_ADDRESS : constant := 11004;
NO_DATA : constant := 11004;
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
EIO : constant := 10101;
-------------------
-- Control flags --
-------------------
-- Control Flags
FIONBIO : constant := -2147195266; -- Set/clear non-blocking io
FIONREAD : constant := 1074030207; -- How many bytes to read
FIONBIO : constant := -2147195266;
FIONREAD : constant := 1074030207;
--------------------
-- Shutdown modes --
--------------------
-- Shutdown Modes
SHUT_RD : constant := 0; -- No more recv
SHUT_WR : constant := 1; -- No more send
SHUT_RDWR : constant := 2; -- No more recv/send
SHUT_RD : constant := 0;
SHUT_WR : constant := 1;
SHUT_RDWR : constant := 2;
---------------------
-- Protocol levels --
---------------------
-- 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
SOL_SOCKET : constant := 65535;
IPPROTO_IP : constant := 0;
IPPROTO_UDP : constant := 17;
IPPROTO_TCP : constant := 6;
-------------------
-- Request flags --
-------------------
-- Socket Options
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
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;
--------------------
-- 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;

345
gcc/ada/3wsocthi.adb
View file

@ -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,33 +50,237 @@ package body GNAT.Sockets.Thin is
WS_Version : constant := 16#0101#;
Initialized : Boolean := False;
-----------
-- Clear --
-----------
SYSNOTREADY : constant := 10091;
VERNOTSUPPORTED : constant := 10092;
NOTINITIALISED : constant := 10093;
EDISCON : constant := 10101;
procedure Clear
(Item : in out Fd_Set;
Socket : C.int)
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 if;
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);
begin
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;
end Clear;
return Count;
end C_Readv;
-----------
-- Empty --
-----------
--------------
-- C_Select --
--------------
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;
procedure Empty (Item : in out Fd_Set) is
begin
Item := Null_Fd_Set;
end Empty;
-- 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;
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;
--------------
-- C_Writev --
--------------
function C_Writev
(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);
begin
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;
--------------
-- Finalize --
@ -81,35 +294,13 @@ package body GNAT.Sockets.Thin is
end if;
end Finalize;
--------------
-- Is_Empty --
--------------
function Is_Empty (Item : Fd_Set) return Boolean is
begin
return Item.fd_count = 0;
end Is_Empty;
------------
-- Is_Set --
------------
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;
end if;
end loop;
return False;
end Is_Set;
----------------
-- 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 --
-----------------
function Max (Item : Fd_Set) return C.int is
L : C.int := 0;
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
for J in 1 .. Item.fd_count loop
if Item.fd_array (J) > L then
L := Item.fd_array (J);
end if;
end loop;
null;
end Set_Length;
return L;
end Max;
--------------
-- Set_Port --
--------------
---------
-- Set --
---------
procedure Set (Item : in out Fd_Set; Socket : in C.int) is
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 --

161
gcc/ada/3wsocthi.ads
View file

@ -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 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 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 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;

16
gcc/ada/3wsoliop.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------
-- 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 Windows/NT version of this package
package GNAT.Sockets.Linker_Options is
-- Windows NT version of this package
private
pragma Linker_Options ("-lwsock32");
end GNAT.Sockets.Linker_Options;

158
gcc/ada/3zsoccon.ads Normal file
View file

@ -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;

632
gcc/ada/3zsocthi.adb Normal file
View file

@ -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;

446
gcc/ada/3zsocthi.ads Normal file
View file

@ -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;

2
gcc/ada/41intnam.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

2
gcc/ada/42intnam.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

2
gcc/ada/4aintnam.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

2
gcc/ada/4cintnam.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

97
gcc/ada/4dintnam.ads
View file

@ -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;

20
gcc/ada/4gintnam.ads
View file

@ -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

2
gcc/ada/4hexcpol.adb
View file

@ -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. --
-- --
------------------------------------------------------------------------------

16
gcc/ada/4hintnam.ads
View file

@ -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

2
gcc/ada/4lintnam.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

145
gcc/ada/4mintnam.ads
View file

@ -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;

2
gcc/ada/4nintnam.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

8
gcc/ada/4ointnam.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

2
gcc/ada/4onumaux.ads
View file

@ -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- --

2
gcc/ada/4pintnam.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

2
gcc/ada/4sintnam.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

154
gcc/ada/4uintnam.ads
View file

@ -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;

8
gcc/ada/4vcaldel.adb
View file

@ -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. --
-- --
------------------------------------------------------------------------------

43
gcc/ada/4vcalend.adb
View file

@ -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;
----------

2
gcc/ada/4vintnam.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

2
gcc/ada/4wexcpol.adb
View file

@ -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. --
-- --
------------------------------------------------------------------------------

4
gcc/ada/4wintnam.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

2
gcc/ada/4zintnam.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

163
gcc/ada/50system.ads Normal file
View file

@ -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;

2
gcc/ada/51osinte.adb
View file

@ -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. --
-- --
------------------------------------------------------------------------------

2
gcc/ada/51osinte.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

24
gcc/ada/52system.ads → gcc/ada/51system.ads
View file

@ -5,9 +5,9 @@
-- S Y S T E M --
-- --
-- S p e c --
-- (LynxOS PPC/x86 Version)
-- (SCO UnixWare Version) --
-- --
-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@ -58,7 +58,7 @@ pragma Pure (System);
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 1.0;
Tick : constant := 0.01;
-- Storage-related Declarations
@ -86,7 +86,7 @@ pragma Pure (System);
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
Default_Bit_Order : constant Bit_Order := High_Order_First;
Default_Bit_Order : constant Bit_Order := Low_Order_First;
-- Priority-related Declarations (RM D.1)
@ -118,21 +118,33 @@ private
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
Long_Shifts_Inlined : constant Boolean := True;
High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := False;
Support_64_Bit_Divides : constant Boolean := True;
Support_Aggregates : constant Boolean := True;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := False;
-- Obsolete entries, to be removed eventually (bootstrap issues!)
High_Integrity_Mode : constant Boolean := False;
Long_Shifts_Inlined : constant Boolean := True;
end System;

8
gcc/ada/52osinte.adb
View file

@ -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;

8
gcc/ada/52osinte.ads
View file

@ -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");

2
gcc/ada/53osinte.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

5
gcc/ada/54osinte.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

150
gcc/ada/55system.ads Normal file
View file

@ -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;

154
gcc/ada/56osinte.adb Normal file
View file

@ -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;

345
gcc/ada/5mosinte.ads → gcc/ada/56osinte.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1997-2001, Free Software Foundation, Inc. --
-- Copyright (C) 2002-2003 Ada Core Technologies, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -27,11 +27,11 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a MACOS (FSU THREAD) version of this package.
-- This is a LynxOS (POSIX Threads) version of this package.
-- This package encapsulates all direct interfaces to OS services
-- that are needed by children of System.
@ -44,7 +44,10 @@ with Interfaces.C;
package System.OS_Interface is
pragma Preelaborate;
pragma Linker_Options ("-lgthreads");
pragma Linker_Options ("-mthreads");
-- Selects the POSIX 1.c runtime, rather than the non-threading runtime
-- or the deprecated legacy threads library. The -mthreads flag is
-- defined in patch.LynxOS and matches the definition for Lynx's gcc.
subtype int is Interfaces.C.int;
subtype short is Interfaces.C.short;
@ -63,7 +66,7 @@ package System.OS_Interface is
function errno return int;
pragma Import (C, errno, "__get_errno");
EAGAIN : constant := 35;
EAGAIN : constant := 11;
EINTR : constant := 4;
EINVAL : constant := 22;
ENOMEM : constant := 12;
@ -73,49 +76,71 @@ package System.OS_Interface is
-- Signals --
-------------
Max_Interrupt : constant := 31;
type Signal is new int range 0 .. Max_Interrupt;
for Signal'Size use int'Size;
Max_Interrupt : constant := 63;
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
-- 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, SIGALRM, SIGEMT, SIGCHLD);
Reserved : constant Signal_Set := (SIGKILL, SIGSTOP);
Unmasked : constant Signal_Set :=
(SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, SIGTHREADKILL);
Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP, SIGPRIO);
type sigset_t is private;
@ -135,16 +160,16 @@ package System.OS_Interface is
pragma Import (C, sigemptyset, "sigemptyset");
type struct_sigaction is record
sa_handler : System.Address;
sa_mask : sigset_t;
sa_flags : int;
sa_handler : System.Address;
sa_mask : sigset_t;
sa_flags : int;
end record;
pragma Convention (C, struct_sigaction);
type struct_sigaction_ptr is access all struct_sigaction;
SIG_BLOCK : constant := 1;
SIG_UNBLOCK : constant := 2;
SIG_SETMASK : constant := 3;
SIG_BLOCK : constant := 0;
SIG_UNBLOCK : constant := 1;
SIG_SETMASK : constant := 2;
SIG_DFL : constant := 0;
SIG_IGN : constant := 1;
@ -159,9 +184,8 @@ package System.OS_Interface is
-- Time --
----------
Time_Slice_Supported : constant Boolean := False;
-- Indicates wether time slicing is supported (i.e FSU threads have been
-- compiled with DEF_RR)
Time_Slice_Supported : constant Boolean := True;
-- Indicates whether time slicing is supported
type timespec is private;
@ -174,13 +198,27 @@ package System.OS_Interface is
tp : access timespec) return int;
pragma Import (C, clock_gettime, "clock_gettime");
function clock_getres
(clock_id : clockid_t;
res : access timespec) return int;
pragma Import (C, clock_getres, "clock_getres");
function To_Duration (TS : timespec) return Duration;
pragma Inline (To_Duration);
function To_Timespec (D : Duration) return timespec;
pragma Inline (To_Timespec);
type struct_timezone is record
tz_minuteswest : int;
tz_dsttime : int;
end record;
pragma Convention (C, struct_timezone);
type struct_timezone_ptr is access all struct_timezone;
type struct_timeval is private;
-- This is needed on systems that do not have clock_gettime()
-- but do have gettimeofday().
function To_Duration (TV : struct_timeval) return Duration;
pragma Inline (To_Duration);
@ -192,9 +230,9 @@ package System.OS_Interface is
-- Priority Scheduling --
-------------------------
SCHED_FIFO : constant := 0;
SCHED_RR : constant := 1;
SCHED_OTHER : constant := 2;
SCHED_FIFO : constant := 16#200000#;
SCHED_RR : constant := 16#100000#;
SCHED_OTHER : constant := 16#400000#;
-------------
-- Process --
@ -213,9 +251,6 @@ package System.OS_Interface is
---------
function lwp_self return System.Address;
-- lwp_self does not exist on this thread library, revert to pthread_self
-- which is the closest approximation (with getpid). This function is
-- needed to share 7staprop.adb across POSIX-like targets.
pragma Import (C, lwp_self, "pthread_self");
-------------
@ -224,7 +259,6 @@ package System.OS_Interface is
type Thread_Body is access
function (arg : System.Address) return System.Address;
type pthread_t is private;
subtype Thread_Id is pthread_t;
@ -236,57 +270,54 @@ package System.OS_Interface is
type pthread_key_t is private;
PTHREAD_CREATE_DETACHED : constant := 1;
PTHREAD_CREATE_JOINABLE : constant := 0;
-----------
-- Stack --
-----------
Stack_Base_Available : constant Boolean := False;
-- Indicates wether the stack base is available on this target.
-- This allows us to share s-osinte.adb between all the FSU run time.
-- Note that this value can only be true if pthread_t has a complete
-- definition that corresponds exactly to the C header files.
-- Indicates whether the stack base is available on this target.
function Get_Stack_Base (thread : pthread_t) return Address;
pragma Inline (Get_Stack_Base);
-- returns the stack base of the specified thread.
-- Returns the stack base of the specified thread.
-- Only call this function when Stack_Base_Available is True.
function Get_Page_Size return size_t;
function Get_Page_Size return Address;
pragma Import (C, Get_Page_Size, "getpagesize");
-- returns the size of a page, or 0 if this is not relevant on this
-- Returns the size of a page, or 0 if this is not relevant on this
-- target
PROT_NONE : constant := 0;
PROT_READ : constant := 1;
PROT_WRITE : constant := 2;
PROT_EXEC : constant := 4;
PROT_NONE : constant := 1;
PROT_READ : constant := 2;
PROT_WRITE : constant := 4;
PROT_EXEC : constant := 8;
PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
PROT_ON : constant := PROT_NONE;
PROT_ON : constant := PROT_READ;
PROT_OFF : constant := PROT_ALL;
function mprotect (addr : Address; len : size_t; prot : int) return int;
pragma Import (C, mprotect);
---------------------------------------
-- Nonstandard Thread Initialization --
---------------------------------------
-----------------------------------------
-- Nonstandard Thread Initialization --
-----------------------------------------
procedure pthread_init;
-- FSU_THREADS requires pthread_init, which is nonstandard
-- and this should be invoked during the elaboration of s-taprop.adb
pragma Import (C, pthread_init, "pthread_init");
-- This is a dummy procedure to share some GNULLI files
-------------------------
-- POSIX.1c Section 3 --
-------------------------
---------------------------
-- POSIX.1c Section 3 --
---------------------------
function sigwait
(set : access sigset_t;
sig : access Signal) return int;
-- FSU_THREADS has a nonstandard sigwait
pragma Inline (sigwait);
-- LynxOS has non standard sigwait
function pthread_kill
(thread : pthread_t;
@ -298,13 +329,14 @@ package System.OS_Interface is
function pthread_sigmask
(how : int;
set : sigset_t_ptr;
oset : sigset_t_ptr)
return int;
pragma Import (C, pthread_sigmask, "sigprocmask");
oset : sigset_t_ptr) return int;
pragma Import (C, pthread_sigmask, "pthread_sigmask");
-- The behavior of pthread_sigmask on LynxOS requires
-- further investigation.
--------------------------
-- POSIX.1c Section 11 --
--------------------------
----------------------------
-- POSIX.1c Section 11 --
----------------------------
function pthread_mutexattr_init
(attr : access pthread_mutexattr_t) return int;
@ -323,10 +355,10 @@ package System.OS_Interface is
pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
-- FSU_THREADS has nonstandard pthread_mutex_lock
pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
-- FSU_THREADS has nonstandard pthread_mutex_lock
pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
function pthread_condattr_init
(attr : access pthread_condattr_t) return int;
@ -350,13 +382,13 @@ package System.OS_Interface is
function pthread_cond_wait
(cond : access pthread_cond_t;
mutex : access pthread_mutex_t) return int;
-- FSU_THREADS has a nonstandard pthread_cond_wait
pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
function pthread_cond_timedwait
(cond : access pthread_cond_t;
mutex : access pthread_mutex_t;
abstime : access timespec) return int;
-- FSU_THREADS has a nonstandard pthread_cond_timedwait
pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
Relative_Timed_Wait : constant Boolean := False;
-- pthread_cond_timedwait requires an absolute delay time
@ -366,8 +398,8 @@ package System.OS_Interface is
--------------------------
PTHREAD_PRIO_NONE : constant := 0;
PTHREAD_PRIO_PROTECT : constant := 2;
PTHREAD_PRIO_INHERIT : constant := 1;
PTHREAD_PRIO_PROTECT : constant := 2;
function pthread_mutexattr_setprotocol
(attr : access pthread_mutexattr_t;
@ -375,21 +407,19 @@ package System.OS_Interface is
pragma Import (C, pthread_mutexattr_setprotocol);
function pthread_mutexattr_setprioceiling
(attr : access pthread_mutexattr_t;
(attr : access pthread_mutexattr_t;
prioceiling : int) return int;
pragma Import
(C, pthread_mutexattr_setprioceiling,
"pthread_mutexattr_setprio_ceiling");
pragma Import (C, pthread_mutexattr_setprioceiling);
type struct_sched_param is record
sched_priority : int; -- scheduling priority
sched_priority : int;
end record;
function pthread_setschedparam
(thread : pthread_t;
policy : int;
param : access struct_sched_param) return int;
-- FSU_THREADS does not have pthread_setschedparam
pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
function pthread_attr_setscope
(attr : access pthread_attr_t;
@ -397,22 +427,17 @@ package System.OS_Interface is
pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
function pthread_attr_setinheritsched
(attr : access pthread_attr_t;
(attr : access pthread_attr_t;
inheritsched : int) return int;
pragma Import (C, pthread_attr_setinheritsched);
function pthread_attr_setschedpolicy
(attr : access pthread_attr_t;
policy : int) return int;
pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched");
function pthread_attr_setschedparam
(attr : access pthread_attr_t;
sched_param : int) return int;
pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam");
pragma Import (C, pthread_attr_setschedpolicy);
function sched_yield return int;
-- FSU_THREADS does not have sched_yield;
pragma Import (C, sched_yield, "sched_yield");
---------------------------
-- P1003.1c - Section 16 --
@ -428,7 +453,7 @@ package System.OS_Interface is
function pthread_attr_setdetachstate
(attr : access pthread_attr_t;
detachstate : int) return int;
-- FSU_THREADS has a nonstandard pthread_attr_setdetachstate
pragma Import (C, pthread_attr_setdetachstate);
function pthread_attr_setstacksize
(attr : access pthread_attr_t;
@ -452,26 +477,31 @@ package System.OS_Interface is
-- POSIX.1c Section 17 --
--------------------------
function pthread_setspecific
function st_setspecific
(key : pthread_key_t;
value : System.Address) return int;
pragma Import (C, pthread_setspecific, "pthread_setspecific");
pragma Import (C, st_setspecific, "st_setspecific");
function pthread_getspecific (key : pthread_key_t) return System.Address;
-- FSU_THREADS has a nonstandard pthread_getspecific
function st_getspecific
(key : pthread_key_t;
retval : System.Address) return int;
pragma Import (C, st_getspecific, "st_getspecific");
type destructor_pointer is access procedure (arg : System.Address);
function pthread_key_create
(key : access pthread_key_t;
destructor : destructor_pointer) return int;
pragma Import (C, pthread_key_create, "pthread_key_create");
function st_keycreate
(destructor : destructor_pointer;
key : access pthread_key_t) return int;
pragma Import (C, st_keycreate, "st_keycreate");
private
type sigset_t is new int;
type sigset_t is record
X1, X2 : long;
end record;
pragma Convention (C, sigset_t);
type pid_t is new int;
type pid_t is new long;
type time_t is new long;
@ -481,76 +511,71 @@ private
end record;
pragma Convention (C, timespec);
type clockid_t is new int;
type clockid_t is new unsigned_char;
CLOCK_REALTIME : constant clockid_t := 0;
type struct_timeval is record
tv_sec : long;
tv_usec : long;
tv_sec : time_t;
tv_usec : time_t;
end record;
pragma Convention (C, struct_timeval);
type st_attr_t is record
stksize : int;
prio : int;
inheritsched : int;
state : int;
sched : int;
detachstate : int;
guardsize : int;
end record;
pragma Convention (C, st_attr_t);
type pthread_attr_t is record
flags : int;
stacksize : int;
contentionscope : int;
inheritsched : int;
detachstate : int;
sched : int;
prio : int;
starttime : timespec;
deadline : timespec;
period : timespec;
pthread_attr_magic : unsigned;
st : st_attr_t;
pthread_attr_scope : int;
end record;
pragma Convention (C, pthread_attr_t);
type pthread_condattr_t is record
flags : int;
cv_magic : unsigned;
cv_pshared : unsigned;
end record;
pragma Convention (C, pthread_condattr_t);
type pthread_mutexattr_t is record
flags : int;
prio_ceiling : int;
protocol : int;
m_flags : unsigned;
m_prio_c : int;
m_pshared : int;
end record;
pragma Convention (C, pthread_mutexattr_t);
type sigjmp_buf is array (Integer range 0 .. 9) of int;
type tid_t is new short;
type pthread_t is new tid_t;
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 block_obj_t is new System.Address;
-- typedef struct _block_obj_s {
-- struct st_entry *b_head;
-- } block_obj_t;
type pthread_mutex_t is record
queue : queue_t;
lock : plain_char;
owner : System.Address;
flags : int;
prio_ceiling : int;
protocol : int;
prev_max_ceiling_prio : int;
m_flags : unsigned;
m_owner : tid_t;
m_wait : block_obj_t;
m_prio_c : int;
m_oldprio : int;
m_count : int;
m_referenced : int;
end record;
pragma Convention (C, pthread_mutex_t);
type pthread_mutex_t_ptr is access all pthread_mutex_t;
type pthread_cond_t is record
queue : queue_t;
flags : int;
waiters : int;
mutex : System.Address;
cv_magic : unsigned;
cv_wait : block_obj_t;
cv_mutex : pthread_mutex_t_ptr;
cv_refcnt : int;
end record;
pragma Convention (C, pthread_cond_t);

1201
gcc/ada/56taprop.adb Normal file
View file

File diff suppressed because it is too large Load diff

107
gcc/ada/5qtaspri.ads → gcc/ada/56taspri.ads
View file

@ -6,7 +6,8 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1991-2001, Florida State University --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -26,32 +27,33 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. It is --
-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
-- State University (http://www.gnat.com). --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- RT_GNU/Linux version
-- This is a LynxOS version of this package, derived from
-- 7staspri.ads
pragma Polling (Off);
-- Turn off polling, we do not want ATC polling to take place during
-- tasking operations. It causes infinite loops and other problems.
with System.OS_Interface;
-- used for pthread_mutex_t
-- pthread_cond_t
-- pthread_t
package System.Task_Primitives is
type Lock is limited private;
-- Used for implementation of protected objects.
type Lock_Ptr is limited private;
-- Should be used for implementation of protected objects.
type RTS_Lock is limited private;
-- Used inside the runtime system. The difference between Lock and the
-- RTS_Lock is that the later one serves only as a semaphore so that do
-- not check for ceiling violations.
type RTS_Lock_Ptr is limited private;
-- Should be used inside the runtime system.
-- The difference between Lock and the RTS_Lock is that the later
-- one serves only as a semaphore so that do not check for
-- ceiling violations.
type Task_Body_Access is access procedure;
-- Pointer to the task body's entry point (or possibly a wrapper
@ -64,75 +66,32 @@ package System.Task_Primitives is
private
type RT_GNU_Linux_Lock is record
Ceiling_Priority : System.Any_Priority;
Pre_Locking_Priority : System.Any_Priority;
-- Used to store the task's active priority before it
-- acquires the lock
Owner : System.Address;
-- This is really a Task_ID, but we can't use that type
-- here because this System.Tasking is "with"
-- the current package -- a circularity.
type Lock is record
Mutex : aliased System.OS_Interface.pthread_mutex_t;
Ceiling : System.Any_Priority;
Saved_Priority : System.Any_Priority;
end record;
type Lock is new RT_GNU_Linux_Lock;
type RTS_Lock is new RT_GNU_Linux_Lock;
type RTS_Lock_Ptr is access all RTS_Lock;
type Lock_Ptr is access all Lock;
type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
type Private_Data is record
Stack : System.Address;
-- A stack space needed for the task. the space is allocated
-- when the task is being created and is deallocated when
-- the TCB for the task is finalized
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.
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
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.
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
CV : aliased System.OS_Interface.pthread_cond_t;
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
L : aliased RTS_Lock;
-- Protection for all components is lock L
end record;
-- ???? May need to use pragma Atomic or Volatile on some
-- components; may also need to specify aliased for some.
end System.Task_Primitives;

110
gcc/ada/56tpopsp.adb Normal file
View file

@ -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;

150
gcc/ada/57system.ads Normal file
View file

@ -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;

150
gcc/ada/58system.ads Normal file
View file

@ -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;

164
gcc/ada/59system.ads Normal file
View file

@ -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;

385
gcc/ada/5aml-tgt.adb Normal file
View file

@ -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;

2
gcc/ada/5aosinte.adb
View file

@ -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. --
-- --
------------------------------------------------------------------------------

2
gcc/ada/5aosinte.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

15
gcc/ada/5asystem.ads
View file

@ -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.

254
gcc/ada/5ataprop.adb
View file

@ -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

24
gcc/ada/5atasinf.ads
View file

@ -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);

2
gcc/ada/5ataspri.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

196
gcc/ada/5atpopsp.adb
View file

@ -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
-- 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);
-- Create a free ATCB for use on the Fake_ATCB_List.
Next_Fake_ATCB := new Fake_ATCB;
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 --
---------
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;

2
gcc/ada/5avxwork.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

398
gcc/ada/5bml-tgt.adb Normal file
View file

@ -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;

23
gcc/ada/5bosinte.adb
View file

@ -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;

2
gcc/ada/5bosinte.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

15
gcc/ada/5bsystem.ads
View file

@ -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;

2
gcc/ada/5cosinte.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

160
gcc/ada/5csystem.ads Normal file
View file

@ -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;

536
gcc/ada/5dosinte.ads
View file

@ -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;

158
gcc/ada/5dsystem.ads Normal file
View file

@ -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;

15
gcc/ada/5esystem.ads
View file

@ -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;

94
gcc/ada/5fintman.adb
View file

@ -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");
for I in Exception_Interrupts'Range loop
Keep_Unmasked (Exception_Interrupts (I)) := True;
end loop;
-- Get interrupt state. Defined in a-init.c
-- The input argument is the interrupt number,
-- and the result is one of the following:
-- 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.
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)
if Unreserve_All_Interrupts = 0 then
Keep_Unmasked (SIGINT) := True;
end if;
begin
Abort_Task_Interrupt := SIGABRT;
Keep_Unmasked (Abort_Task_Interrupt) := True;
-- Change this if you want to use another signal for task abort.
-- SIGTERM might be a good one.
Reserve := Keep_Unmasked or Keep_Masked;
Reserve (0) := 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;
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;
-- 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
-- mark it as reserved.
Reserve (0) := True;
end;
end System.Interrupt_Management;

120
gcc/ada/5fosinte.adb Normal file
View file

@ -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;

2
gcc/ada/5fosinte.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

15
gcc/ada/5fsystem.ads
View file

@ -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.

204
gcc/ada/5ftaprop.adb
View file

@ -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)
--

24
gcc/ada/5ftasinf.ads
View file

@ -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

14
gcc/ada/5ginterr.adb
View file

@ -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

97
gcc/ada/5gintman.adb
View file

@ -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:
for I in Reserved_Interrupts'Range loop
Keep_Unmasked (Reserved_Interrupts (I)) := True;
Reserve (Reserved_Interrupts (I)) := True;
end loop;
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;
Reserve (Reserved_Interrupts (I)) := True;
end loop;
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:
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
-- mark it as reserved.
Reserve (0) := True;
end;
end System.Interrupt_Management;

12
gcc/ada/5gmastop.adb
View file

@ -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;

368
gcc/ada/5gml-tgt.adb Normal file
View file

@ -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;

2
gcc/ada/5gosinte.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

3
gcc/ada/5gproinf.ads
View file

@ -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.

24
gcc/ada/5gsystem.ads
View file

@ -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.

75
gcc/ada/5gtaprop.adb
View file

@ -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;

23
gcc/ada/5gtasinf.ads
View file

@ -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;

2
gcc/ada/5gtpgetc.adb
View file

@ -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. --
-- --
------------------------------------------------------------------------------

373
gcc/ada/5hml-tgt.adb Normal file
View file

@ -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;

21
gcc/ada/5hosinte.adb
View file

@ -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;

8
gcc/ada/5hosinte.ads
View file

@ -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. --
-- --
------------------------------------------------------------------------------

14
gcc/ada/5hparame.ads
View file

@ -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 --
--------------------

Some files were not shown because too many files have changed in this diff Show more