2003-10-21 Arnaud Charlet <charlet@act-europe.fr>

	* 3psoccon.ads, 3veacodu.adb, 3vexpect.adb, 3vsoccon.ads,
	3vsocthi.adb, 3vsocthi.ads, 3vtrasym.adb, 3zsoccon.ads,
	3zsocthi.adb, 3zsocthi.ads, 50system.ads, 51system.ads,
	55system.ads, 56osinte.adb, 56osinte.ads, 56taprop.adb,
	56taspri.ads, 56tpopsp.adb, 57system.ads, 58system.ads,
	59system.ads, 5aml-tgt.adb, 5bml-tgt.adb, 5csystem.ads,
	5dsystem.ads, 5fosinte.adb, 5gml-tgt.adb, 5hml-tgt.adb,
	5isystem.ads, 5lparame.adb, 5msystem.ads, 5psystem.ads,
	5sml-tgt.adb, 5sosprim.adb, 5stpopsp.adb, 5tsystem.ads,
	5usystem.ads, 5vml-tgt.adb, 5vsymbol.adb, 5vtraent.adb,
	5vtraent.ads, 5wml-tgt.adb, 5xparame.ads, 5xsystem.ads,
	5xvxwork.ads, 5yparame.ads, 5ytiitho.adb, 5zinit.adb,
	5zml-tgt.adb, 5zparame.ads, 5ztaspri.ads, 5ztfsetr.adb,
	5zthrini.adb, 5ztiitho.adb, 5ztpopsp.adb, 7stfsetr.adb,
	7straces.adb, 7strafor.adb, 7strafor.ads, 7stratas.adb,
	a-excach.adb, a-exexda.adb, a-exexpr.adb, a-exextr.adb,
	a-exstat.adb, a-strsup.adb, a-strsup.ads, a-stwisu.adb,
	a-stwisu.ads, bld.adb, bld.ads, bld-io.adb,
	bld-io.ads, clean.adb, clean.ads, ctrl_c.c,
	erroutc.adb, erroutc.ads, errutil.adb, errutil.ads,
	err_vars.ads, final.c, g-arrspl.adb, g-arrspl.ads,
	g-boubuf.adb, g-boubuf.ads, g-boumai.ads, g-bubsor.adb,
	g-bubsor.ads, g-comver.adb, g-comver.ads, g-ctrl_c.ads,
	g-dynhta.adb, g-dynhta.ads, g-eacodu.adb, g-excact.adb,
	g-excact.ads, g-heasor.adb, g-heasor.ads, g-memdum.adb,
	g-memdum.ads, gnatclean.adb, gnatsym.adb, g-pehage.adb,
	g-pehage.ads, g-perhas.ads, gpr2make.adb, gpr2make.ads,
	gprcmd.adb, gprep.adb, gprep.ads, g-semaph.adb,
	g-semaph.ads, g-string.adb, g-string.ads, g-strspl.ads,
	g-wistsp.ads, i-vthrea.adb, i-vthrea.ads, i-vxwoio.adb,
	i-vxwoio.ads, Makefile.generic, Makefile.prolog, Makefile.rtl,
	prep.adb, prep.ads, prepcomp.adb, prepcomp.ads,
	prj-err.adb, prj-err.ads, s-boarop.ads, s-carsi8.adb,
	s-carsi8.ads, s-carun8.adb, s-carun8.ads, s-casi16.adb,
	s-casi16.ads, s-casi32.adb, s-casi32.ads, s-casi64.adb,
	s-casi64.ads, s-casuti.adb, s-casuti.ads, s-caun16.adb,
	s-caun16.ads, s-caun32.adb, s-caun32.ads, s-caun64.adb,
	s-caun64.ads, scng.adb, scng.ads, s-exnint.adb,
	s-exnllf.adb, s-exnlli.adb, s-expint.adb, s-explli.adb,
	s-geveop.adb, s-geveop.ads, s-hibaen.ads, s-htable.adb,
	s-htable.ads, sinput-c.adb, sinput-c.ads, s-memcop.ads,
	socket.c, s-purexc.ads, s-scaval.adb, s-stopoo.adb,
	s-strcom.adb, s-strcom.ads, s-strxdr.adb, s-rident.ads,
	s-thread.adb, s-thread.ads, s-tpae65.adb, s-tpae65.ads,
	s-tporft.adb, s-traent.adb, s-traent.ads, styleg.adb,
	styleg.ads, styleg-c.adb, styleg-c.ads, s-veboop.adb,
	s-veboop.ads, s-vector.ads, symbols.adb, symbols.ads,
	tb-alvms.c, tb-alvxw.c, tempdir.adb, tempdir.ads,
	vms_conv.ads, vms_conv.adb, vms_data.ads,
	vxaddr2line.adb: Files added. Merge with ACT tree.

	* 4dintnam.ads, 4mintnam.ads, 4uintnam.ads, 52system.ads,
	5dosinte.ads, 5etpopse.adb, 5mosinte.ads, 5qosinte.adb,
	5qosinte.ads, 5qstache.adb, 5qtaprop.adb, 5qtaspri.ads,
	5stpopse.adb, 5uintman.adb, 5uosinte.ads, adafinal.c,
	g-enblsp.adb, io-aux.c, scn-nlit.adb, scn-slit.adb,
	s-exnflt.ads, s-exngen.adb, s-exngen.ads, s-exnlfl.ads,
	s-exnlin.ads, s-exnsfl.ads, s-exnsin.ads, s-exnssi.ads,
	s-expflt.ads, s-expgen.adb, s-expgen.ads, s-explfl.ads,
	s-explin.ads, s-expllf.ads, s-expsfl.ads, s-expsin.ads,
	s-expssi.ads, style.adb: Files removed. Merge with ACT tree.

	* 1ic.ads, 31soccon.ads, 31soliop.ads, 3asoccon.ads,
	3bsoccon.ads, 3gsoccon.ads, 3hsoccon.ads, 3ssoccon.ads,
	3ssoliop.ads, 3wsoccon.ads, 3wsocthi.adb, 3wsocthi.ads,
	3wsoliop.ads, 41intnam.ads, 42intnam.ads, 4aintnam.ads,
	4cintnam.ads, 4gintnam.ads, 4hexcpol.adb, 4hintnam.ads,
	4lintnam.ads, 4nintnam.ads, 4ointnam.ads, 4onumaux.ads,
	4pintnam.ads, 4sintnam.ads, 4vcaldel.adb, 4vcalend.adb,
	4vintnam.ads, 4wexcpol.adb, 4wintnam.ads, 4zintnam.ads,
	51osinte.adb, 51osinte.ads, 52osinte.adb, 52osinte.ads,
	53osinte.ads, 54osinte.ads, 5aosinte.adb, 5aosinte.ads,
	5asystem.ads, 5ataprop.adb, 5atasinf.ads, 5ataspri.ads,
	5atpopsp.adb, 5avxwork.ads, 5bosinte.adb, 5bosinte.ads,
	5bsystem.ads, 5cosinte.ads, 5esystem.ads, 5fintman.adb,
	5fosinte.ads, 5fsystem.ads, 5ftaprop.adb, 5ftasinf.ads,
	5ginterr.adb, 5gintman.adb, 5gmastop.adb, 5gosinte.ads,
	5gproinf.ads, 5gsystem.ads, 5gtaprop.adb, 5gtasinf.ads,
	5gtpgetc.adb, 5hosinte.adb, 5hosinte.ads, 5hsystem.ads,
	5htaprop.adb, 5htaspri.ads, 5htraceb.adb, 5iosinte.adb,
	5itaprop.adb, 5itaspri.ads, 5ksystem.ads, 5kvxwork.ads,
	5lintman.adb, 5lml-tgt.adb, 5losinte.ads, 5lsystem.ads,
	5mvxwork.ads, 5ninmaop.adb, 5nintman.adb, 5nosinte.ads,
	5ntaprop.adb, 5ntaspri.ads, 5ointerr.adb, 5omastop.adb,
	5oosinte.adb, 5oosinte.ads, 5oosprim.adb, 5oparame.adb,
	5osystem.ads, 5otaprop.adb, 5otaspri.ads, 5posinte.ads,
	5posprim.adb, 5pvxwork.ads, 5sintman.adb, 5sosinte.adb,
	5sosinte.ads, 5ssystem.ads, 5staprop.adb, 5stasinf.ads,
	5staspri.ads, 5svxwork.ads, 5tosinte.ads, 5vasthan.adb,
	5vinmaop.adb, 5vinterr.adb, 5vintman.adb, 5vintman.ads,
	5vmastop.adb, 5vosinte.adb, 5vosinte.ads, 5vosprim.adb,
	5vsystem.ads, 5vtaprop.adb, 5vtaspri.ads, 5vtpopde.adb,
	5vtpopde.ads, 5wgloloc.adb, 5wintman.adb, 5wmemory.adb,
	5wosprim.adb, 5wsystem.ads, 5wtaprop.adb, 5wtaspri.ads,
	5ysystem.ads, 5zinterr.adb, 5zintman.adb, 5zosinte.adb,
	5zosinte.ads, 5zosprim.adb, 5zsystem.ads, 5ztaprop.adb,
	6vcpp.adb, 6vcstrea.adb, 6vinterf.ads, 7sinmaop.adb,
	7sintman.adb, 7sosinte.adb, 7sosprim.adb, 7staprop.adb,
	7staspri.ads, 7stpopsp.adb, 7straceb.adb, 9drpc.adb,
	a-caldel.adb, a-caldel.ads, a-charac.ads, a-colien.ads,
	a-comlin.adb, adaint.c, adaint.h, ada-tree.def,
	a-diocst.adb, a-diocst.ads, a-direio.adb, a-except.adb,
	a-except.ads, a-excpol.adb, a-exctra.adb, a-exctra.ads,
	a-filico.adb, a-interr.adb, a-intsig.adb, a-intsig.ads,
	ali.adb, ali.ads, ali-util.adb, ali-util.ads,
	a-ngcefu.adb, a-ngcoty.adb, a-ngelfu.adb, a-nudira.adb,
	a-nudira.ads, a-nuflra.adb, a-nuflra.ads, a-reatim.adb,
	a-reatim.ads, a-retide.ads, a-sequio.adb, a-siocst.adb,
	a-siocst.ads, a-ssicst.adb, a-ssicst.ads, a-strbou.adb,
	a-strbou.ads, a-strfix.adb, a-strmap.adb, a-strsea.ads,
	a-strunb.adb, a-strunb.ads, a-ststio.adb, a-stunau.adb,
	a-stunau.ads, a-stwibo.adb, a-stwibo.ads, a-stwifi.adb,
	a-stwima.adb, a-stwiun.adb, a-stwiun.ads, a-tags.adb,
	a-tags.ads, a-tasatt.adb, a-taside.adb, a-teioed.adb,
	a-textio.adb, a-textio.ads, a-tienau.adb, a-tifiio.adb,
	a-tiflau.adb, a-tiflio.adb, a-tigeau.adb, a-tigeau.ads,
	a-tiinau.adb, a-timoau.adb, a-tiocst.adb, a-tiocst.ads,
	atree.adb, atree.ads, a-witeio.adb, a-witeio.ads,
	a-wtcstr.adb, a-wtcstr.ads, a-wtdeio.adb, a-wtedit.adb,
	a-wtenau.adb, a-wtflau.adb, a-wtinau.adb, a-wtmoau.adb,
	bcheck.adb, binde.adb, bindgen.adb, bindusg.adb,
	checks.adb, checks.ads, cio.c, comperr.adb,
	comperr.ads, csets.adb, cstand.adb, cstreams.c,
	debug_a.adb, debug_a.ads, debug.adb, decl.c,
	einfo.adb, einfo.ads, errout.adb, errout.ads,
	eval_fat.adb, eval_fat.ads, exp_aggr.adb, expander.adb,
	expander.ads, exp_attr.adb, exp_ch11.adb, exp_ch13.adb,
	exp_ch2.adb, exp_ch3.adb, exp_ch3.ads, exp_ch4.adb,
	exp_ch5.adb, exp_ch6.adb, exp_ch7.adb, exp_ch7.ads,
	exp_ch8.adb, exp_ch9.adb, exp_code.adb, exp_dbug.adb,
	exp_dbug.ads, exp_disp.adb, exp_dist.adb, expect.c,
	exp_fixd.adb, exp_imgv.adb, exp_intr.adb, exp_pakd.adb,
	exp_prag.adb, exp_strm.adb, exp_strm.ads, exp_tss.adb,
	exp_tss.ads, exp_util.adb, exp_util.ads, exp_vfpt.adb,
	fe.h, fmap.adb, fmap.ads, fname.adb,
	fname.ads, fname-uf.adb, fname-uf.ads, freeze.adb,
	freeze.ads, frontend.adb, g-awk.adb, g-awk.ads,
	g-busora.adb, g-busora.ads, g-busorg.adb, g-busorg.ads,
	g-casuti.adb, g-casuti.ads, g-catiio.adb, g-catiio.ads,
	g-cgi.adb, g-cgi.ads, g-cgicoo.adb, g-cgicoo.ads,
	g-cgideb.adb, g-cgideb.ads, g-comlin.adb, g-comlin.ads,
	g-crc32.adb, g-crc32.ads, g-debpoo.adb, g-debpoo.ads,
	g-debuti.adb, g-debuti.ads, g-diopit.adb, g-diopit.ads,
	g-dirope.adb, g-dirope.ads, g-dyntab.adb, g-dyntab.ads,
	g-except.ads, g-exctra.adb, g-exctra.ads, g-expect.adb,
	g-expect.ads, g-hesora.adb, g-hesora.ads, g-hesorg.adb,
	g-hesorg.ads, g-htable.adb, g-htable.ads, gigi.h,
	g-io.adb, g-io.ads, g-io_aux.adb, g-io_aux.ads,
	g-locfil.adb, g-locfil.ads, g-md5.adb, g-md5.ads,
	gmem.c, gnat1drv.adb, gnatbind.adb, gnatchop.adb,
	gnatcmd.adb, gnatfind.adb, gnatkr.adb, gnatlbr.adb,
	gnatlink.adb, gnatls.adb, gnatmake.adb, gnatmem.adb,
	gnatname.adb, gnatprep.adb, gnatprep.ads, gnatpsta.adb,
	gnatxref.adb, g-os_lib.adb, g-os_lib.ads, g-regexp.adb,
	g-regexp.ads, g-regist.adb, g-regist.ads, g-regpat.adb,
	g-regpat.ads, g-soccon.ads, g-socket.adb, g-socket.ads,
	g-socthi.adb, g-socthi.ads, g-soliop.ads, g-souinf.ads,
	g-speche.adb, g-speche.ads, g-spipat.adb, g-spipat.ads,
	g-spitbo.adb, g-spitbo.ads, g-sptabo.ads, g-sptain.ads,
	g-sptavs.ads, g-table.adb, g-table.ads, g-tasloc.adb,
	g-tasloc.ads, g-thread.adb, g-thread.ads, g-traceb.adb,
	g-traceb.ads, g-trasym.adb, g-trasym.ads, hostparm.ads,
	i-c.ads, i-cobol.adb, i-cpp.adb, i-cstrea.ads,
	i-cstrin.adb, i-cstrin.ads, impunit.adb, init.c,
	inline.adb, interfac.ads, i-pacdec.ads, itypes.adb,
	itypes.ads, i-vxwork.ads, lang.opt, lang-specs.h,
	layout.adb, lib.adb, lib.ads, lib-list.adb,
	lib-load.adb, lib-load.ads, lib-sort.adb, lib-util.adb,
	lib-writ.adb, lib-writ.ads, lib-xref.adb, lib-xref.ads,
	link.c, live.adb, make.adb, make.ads,
	Makefile.adalib, Makefile.in, Make-lang.in, makeusg.adb,
	mdll.adb, mdll-fil.adb, mdll-fil.ads, mdll-utl.adb,
	mdll-utl.ads, memroot.adb, memroot.ads, memtrack.adb,
	misc.c, mkdir.c, mlib.adb, mlib.ads,
	mlib-fil.adb, mlib-fil.ads, mlib-prj.adb, mlib-prj.ads,
	mlib-tgt.adb, mlib-tgt.ads, mlib-utl.adb, mlib-utl.ads,
	namet.adb, namet.ads, namet.h, nlists.ads,
	nlists.h, nmake.adt, opt.adb, opt.ads,
	osint.adb, osint.ads, osint-b.adb, osint-c.adb,
	par.adb, par-ch10.adb, par-ch11.adb, par-ch2.adb,
	par-ch3.adb, par-ch4.adb, par-ch5.adb, par-ch6.adb,
	par-ch9.adb, par-endh.adb, par-labl.adb, par-load.adb,
	par-prag.adb, par-sync.adb, par-tchk.adb, par-util.adb,
	prj.adb, prj.ads, prj-attr.adb, prj-attr.ads,
	prj-com.adb, prj-com.ads, prj-dect.adb, prj-dect.ads,
	prj-env.adb, prj-env.ads, prj-ext.adb, prj-ext.ads,
	prj-makr.adb, prj-makr.ads, prj-nmsc.adb, prj-nmsc.ads,
	prj-pars.adb, prj-pars.ads, prj-part.adb, prj-part.ads,
	prj-pp.adb, prj-pp.ads, prj-proc.adb, prj-proc.ads,
	prj-strt.adb, prj-strt.ads, prj-tree.adb, prj-tree.ads,
	prj-util.adb, prj-util.ads, raise.c, raise.h,
	repinfo.adb, repinfo.h, restrict.adb, restrict.ads,
	rident.ads, rtsfind.adb, rtsfind.ads, s-addima.ads,
	s-arit64.adb, s-assert.adb, s-assert.ads, s-atacco.adb,
	s-atacco.ads, s-auxdec.adb, s-auxdec.ads, s-bitops.adb,
	scans.ads, scn.adb, scn.ads, s-crc32.adb,
	s-crc32.ads, s-direio.adb, sem.adb, sem.ads,
	sem_aggr.adb, sem_attr.adb, sem_attr.ads, sem_case.adb,
	sem_case.ads, sem_cat.adb, sem_cat.ads, sem_ch10.adb,
	sem_ch11.adb, sem_ch12.adb, sem_ch12.ads, sem_ch13.adb,
	sem_ch13.ads, sem_ch3.adb, sem_ch3.ads, sem_ch4.adb,
	sem_ch5.adb, sem_ch5.ads, sem_ch6.adb, sem_ch6.ads,
	sem_ch7.adb, sem_ch7.ads, sem_ch8.adb, sem_ch8.ads,
	sem_ch9.adb, sem_disp.adb, sem_disp.ads, sem_dist.adb,
	sem_elab.adb, sem_eval.adb, sem_eval.ads, sem_intr.adb,
	sem_maps.adb, sem_mech.adb, sem_prag.adb, sem_prag.ads,
	sem_res.adb, sem_res.ads, sem_type.adb, sem_type.ads,
	sem_util.adb, sem_util.ads, sem_warn.adb, s-errrep.adb,
	s-errrep.ads, s-exctab.adb, s-exctab.ads, s-exnint.ads,
	s-exnllf.ads, s-exnlli.ads, s-expint.ads, s-explli.ads,
	s-expuns.ads, s-fatflt.ads, s-fatgen.adb, s-fatgen.ads,
	s-fatlfl.ads, s-fatllf.ads, s-fatsfl.ads, s-fileio.adb,
	s-fileio.ads, s-finimp.adb, s-finimp.ads, s-finroo.adb,
	s-finroo.ads, sfn_scan.adb, s-gloloc.adb, s-gloloc.ads,
	s-imgdec.adb, s-imgenu.adb, s-imgrea.adb, s-imgwch.adb,
	sinfo.adb, sinfo.ads, s-inmaop.ads, sinput.adb,
	sinput.ads, sinput-d.adb, sinput-l.adb, sinput-l.ads,
	sinput-p.adb, sinput-p.ads, s-interr.adb, s-interr.ads,
	s-intman.ads, s-maccod.ads, s-mastop.adb, s-mastop.ads,
	s-memory.adb, s-memory.ads, snames.adb, snames.ads,
	snames.h, s-osprim.ads, s-parame.ads, s-parint.ads,
	s-pooloc.adb, s-pooloc.ads, s-poosiz.adb, sprint.adb,
	s-proinf.ads, s-scaval.ads, s-secsta.adb, s-secsta.ads,
	s-sequio.adb, s-shasto.adb, s-shasto.ads, s-soflin.ads,
	s-stache.adb, s-stache.ads, s-stalib.adb, s-stalib.ads,
	s-stoele.ads, s-stopoo.ads, s-stratt.adb, s-stratt.ads,
	s-strops.adb, s-strops.ads, s-taasde.adb, s-taasde.ads,
	s-tadeca.adb, s-tadeca.ads, s-tadert.adb, s-tadert.ads,
	s-taenca.adb, s-taenca.ads, s-taprob.adb, s-taprob.ads,
	s-taprop.ads, s-tarest.adb, s-tarest.ads, s-tasdeb.adb,
	s-tasdeb.ads, s-tasinf.adb, s-tasinf.ads, s-tasini.adb,
	s-tasini.ads, s-taskin.adb, s-taskin.ads, s-tasque.adb,
	s-tasque.ads, s-tasren.adb, s-tasren.ads, s-tasres.ads,
	s-tassta.adb, s-tassta.ads, s-tasuti.adb, s-tasuti.ads,
	s-tataat.adb, s-tataat.ads, s-tpinop.adb, s-tpinop.ads,
	s-tpoben.adb, s-tpoben.ads, s-tpobop.adb, s-tpobop.ads,
	s-tposen.adb, s-tposen.ads, s-traceb.adb, s-traceb.ads,
	stringt.adb, stringt.ads, stringt.h, style.ads,
	stylesw.adb, stylesw.ads, s-unstyp.ads, s-vaflop.ads,
	s-valrea.adb, s-valuti.adb, s-vercon.adb, s-vmexta.adb,
	s-wchcnv.ads, s-wchcon.ads, s-widcha.adb, switch.adb,
	switch.ads, switch-b.adb, switch-c.adb, switch-m.adb,
	s-wwdcha.adb, s-wwdwch.adb, sysdep.c, system.ads,
	table.adb, table.ads, targparm.adb, targparm.ads,
	targtyps.c, tbuild.adb, tbuild.ads, tracebak.c,
	trans.c, tree_io.adb, treepr.adb, treeprs.adt,
	ttypes.ads, types.ads, types.h, uintp.adb,
	uintp.ads, uintp.h, uname.adb, urealp.adb,
	urealp.ads, urealp.h, usage.adb, utils2.c,
	utils.c, validsw.adb, validsw.ads, widechar.adb,
	xeinfo.adb, xnmake.adb, xref_lib.adb, xref_lib.ads,
	xr_tabls.adb, xr_tabls.ads, xtreeprs.adb, xsnames.adb,
	einfo.h, sinfo.h, treeprs.ads, nmake.ads, nmake.adb,
	gnatvsn.ads: Merge with ACT tree.

	* gnatvsn.adb: Rewritten in a simpler and more efficient way.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@72751 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 1469 insertions, 101 deletions

diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb
index 83c8ba54785..ef853da04e9 100644
--- a/gcc/ada/g-debpoo.adb
+++ b/gcc/ada/g-debpoo.adb
@@ -2,11 +2,11 @@
 --                                                                          --
 --                         GNAT COMPILER COMPONENTS                         --
 --                                                                          --
---                      G N A T . D E B U G _ P O O L S                     --
+--                       G N A T . D E B U G _ P O O L S                    --
 --                                                                          --
---                                B o d y                                   --
+--                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2003 Free Software Foundation, Inc.          --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -31,32 +31,630 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
-with Unchecked_Conversion;
+with Ada.Exceptions.Traceback;
+with GNAT.IO; use GNAT.IO;
+
+with System.Address_Image;
+with System.Memory;     use System.Memory;
+with System.Soft_Links; use System.Soft_Links;
+
+with System.Traceback_Entries; use System.Traceback_Entries;
+
 with GNAT.HTable;
-with System.Memory;
+with GNAT.Traceback; use GNAT.Traceback;
 
-pragma Elaborate_All (GNAT.HTable);
+with Ada.Unchecked_Conversion;
 
 package body GNAT.Debug_Pools is
    use System;
-   use System.Memory;
    use System.Storage_Elements;
 
-   --  Definition of a H-table storing the status of each storage chunck
-   --  used by this pool
+   Default_Alignment : constant Storage_Offset := Standard'Maximum_Alignment;
+   --  Alignment used for the memory chunks returned by Allocate. Using this
+   --  value garantees that this alignment will be compatible with all types
+   --  and at the same time makes it easy to find the location of the extra
+   --  header allocated for each chunk.
+
+   Initial_Memory_Size : constant Storage_Offset := 2 ** 26; --  64 Mb
+   --  Initial size of memory that the debug pool can handle. This is used to
+   --  compute the size of the htable used to monitor the blocks, but this is
+   --  dynamic and will grow as needed. Having a bigger size here means a
+   --  longer setup time, but less time spent later on to grow the array.
+
+   Max_Ignored_Levels : constant Natural := 10;
+   --  Maximum number of levels that will be ignored in backtraces. This is so
+   --  that we still have enough significant levels in the tracebacks returned
+   --  to the user.
+   --  The value 10 is chosen as being greater than the maximum callgraph
+   --  in this package. Its actual value is not really relevant, as long as it
+   --  is high enough to make sure we still have enough frames to return to
+   --  the user after we have hidden the frames internal to this package.
+
+   -----------------------
+   -- Tracebacks_Htable --
+   -----------------------
 
-   type State is (Not_Allocated, Deallocated, Allocated);
+   --  This package needs to store one set of tracebacks for each allocation
+   --  point (when was it allocated or deallocated). This would use too much
+   --  memory,  so the tracebacks are actually stored in a hash table, and
+   --  we reference elements in this hash table instead.
+
+   --  This hash-table will remain empty if the discriminant Stack_Trace_Depth
+   --  for the pools is set to 0.
+
+   --  This table is a global table, that can be shared among all debug pools
+   --  with no problems.
 
    type Header is range 1 .. 1023;
-   function H (F : Address) return Header;
+   --  Number of elements in the hash-table
+
+   type Tracebacks_Array_Access
+      is access GNAT.Traceback.Tracebacks_Array;
+
+   type Traceback_Kind is (Alloc, Dealloc, Indirect_Alloc, Indirect_Dealloc);
+
+   type Traceback_Htable_Elem;
+   type Traceback_Htable_Elem_Ptr
+      is access Traceback_Htable_Elem;
+
+   type Traceback_Htable_Elem is record
+      Traceback : Tracebacks_Array_Access;
+      Kind      : Traceback_Kind;
+      Count     : Natural;
+      Total     : Byte_Count;
+      Next      : Traceback_Htable_Elem_Ptr;
+   end record;
+
+   procedure Set_Next
+     (E    : Traceback_Htable_Elem_Ptr;
+      Next : Traceback_Htable_Elem_Ptr);
+   function Next
+     (E    : Traceback_Htable_Elem_Ptr)
+      return Traceback_Htable_Elem_Ptr;
+   function Get_Key
+     (E    : Traceback_Htable_Elem_Ptr)
+      return Tracebacks_Array_Access;
+   function Hash (T : Tracebacks_Array_Access) return Header;
+   function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean;
+   pragma Inline (Set_Next, Next, Get_Key, Equal, Hash);
+   --  Subprograms required for instantiation of the htable. See GNAT.HTable.
+
+   package Backtrace_Htable is new GNAT.HTable.Static_HTable
+     (Header_Num => Header,
+      Element    => Traceback_Htable_Elem,
+      Elmt_Ptr   => Traceback_Htable_Elem_Ptr,
+      Null_Ptr   => null,
+      Set_Next   => Set_Next,
+      Next       => Next,
+      Key        => Tracebacks_Array_Access,
+      Get_Key    => Get_Key,
+      Hash       => Hash,
+      Equal      => Equal);
+
+   -----------------------
+   -- Allocations table --
+   -----------------------
+
+   type Allocation_Header;
+   type Allocation_Header_Access is access Allocation_Header;
+
+   --  The following record stores extra information that needs to be
+   --  memorized for each block allocated with the special debug pool.
+
+   type Traceback_Ptr_Or_Address is new System.Address;
+   --  A type that acts as a C union, and is either a System.Address or a
+   --  Traceback_Htable_Elem_Ptr.
+
+   type Allocation_Header is record
+      Block_Size : Storage_Offset;
+      --  Needed only for advanced freeing algorithms (traverse all allocated
+      --  blocks for potential references). This value is negated when the
+      --  chunk of memory has been logically freed by the application. This
+      --  chunk has not been physically released yet.
+
+      Alloc_Traceback   : Traceback_Htable_Elem_Ptr;
+      Dealloc_Traceback : Traceback_Ptr_Or_Address;
+      --  Pointer to the traceback for the allocation (if the memory chunck is
+      --  still valid), or to the first deallocation otherwise. Make sure this
+      --  is a thin pointer to save space.
+      --
+      --  Dealloc_Traceback is also for blocks that are still allocated to
+      --  point to the previous block in the list. This saves space in this
+      --  header, and make manipulation of the lists of allocated pointers
+      --  faster.
+
+      Next : System.Address;
+      --  Point to the next block of the same type (either allocated or
+      --  logically freed) in memory. This points to the beginning of the user
+      --  data, and does not include the header of that block.
+   end record;
+
+   function Header_Of (Address : System.Address)
+      return Allocation_Header_Access;
+   pragma Inline (Header_Of);
+   --  Return the header corresponding to a previously allocated address
+
+   function To_Address is new Ada.Unchecked_Conversion
+     (Traceback_Ptr_Or_Address, System.Address);
+   function To_Address is new Ada.Unchecked_Conversion
+     (System.Address, Traceback_Ptr_Or_Address);
+   function To_Traceback is new Ada.Unchecked_Conversion
+     (Traceback_Ptr_Or_Address, Traceback_Htable_Elem_Ptr);
+   function To_Traceback is new Ada.Unchecked_Conversion
+     (Traceback_Htable_Elem_Ptr, Traceback_Ptr_Or_Address);
+
+   Minimum_Allocation : constant Storage_Count :=
+                          Default_Alignment *
+                            (Allocation_Header'Size /
+                               System.Storage_Unit /
+                                 Default_Alignment) +
+                                   Default_Alignment;
+   --  Extra bytes to allocate to store the header. The header needs to be
+   --  correctly aligned as well, so we have to allocate multiples of the
+   --  alignment.
+
+   -----------------------
+   -- Allocations table --
+   -----------------------
+
+   --  This table is indexed on addresses modulo Minimum_Allocation, and
+   --  for each index it indicates whether that memory block is valid.
+   --  Its behavior is similar to GNAT.Table, except that we need to pack
+   --  the table to save space, so we cannot reuse GNAT.Table as is.
+
+   --  This table is the reason why all alignments have to be forced to a
+   --  common value (Default_Alignment), so that this table can be
+   --  kept to a reasonnable size.
+
+   type Byte is mod 2 ** System.Storage_Unit;
+
+   Big_Table_Size : constant Storage_Offset :=
+                      (Storage_Offset'Last - 1) / Default_Alignment;
+   type Big_Table is array (0 .. Big_Table_Size) of Byte;
+   --  A simple, flat-array type used to access memory bytes (see the comment
+   --  for Valid_Blocks below).
+   --
+   --  It would be cleaner to represent this as a packed array of Boolean.
+   --  However, we cannot specify pragma Pack for such an array, since the
+   --  total size on a 64 bit machine would be too big (> Integer'Last).
+   --
+   --  Given an address, we know if it is under control of the debug pool if
+   --  the byte at index:
+   --       ((Address - Edata'Address) / Default_Alignment)
+   --        / Storage_unit
+   --  has the bit
+   --       ((Address - Edata'Address) / Default_Alignment)
+   --        mod Storage_Unit
+   --  set to 1.
+   --
+   --  See the subprograms Is_Valid and Set_Valid for proper manipulation of
+   --  this array.
+
+   type Table_Ptr is access Big_Table;
+   function To_Pointer is new Ada.Unchecked_Conversion
+     (System.Address, Table_Ptr);
+
+   Valid_Blocks      : Table_Ptr      := null;
+   Valid_Blocks_Size : Storage_Offset := 0;
+   --  These two variables represents a mapping of the currently allocated
+   --  memory. Every time the pool works on an address, we first check that the
+   --  index Address / Default_Alignment is True. If not, this means that this
+   --  address is not under control of the debug pool, and thus this is
+   --  probably an invalid memory access (it could also be a general access
+   --  type).
+   --
+   --  Note that in fact we never allocate the full size of Big_Table, only a
+   --  slice big enough to manage the currently allocated memory.
+
+   Edata  : System.Address := System.Null_Address;
+   --  Address in memory that matches the index 0 in Valid_Blocks. It is named
+   --  after the symbol _edata, which, on most systems, indicate the lowest
+   --  possible address returned by malloc (). Unfortunately, this symbol
+   --  doesn't exist on windows, so we cannot use it instead of this variable.
+
+   -----------------------
+   -- Local subprograms --
+   -----------------------
+
+   function Find_Or_Create_Traceback
+     (Pool                : Debug_Pool;
+      Kind                : Traceback_Kind;
+      Size                : Storage_Count;
+      Ignored_Frame_Start : System.Address;
+      Ignored_Frame_End   : System.Address)
+      return                Traceback_Htable_Elem_Ptr;
+   --  Return an element matching the current traceback (omitting the frames
+   --  that are in the current package). If this traceback already existed in
+   --  the htable, a pointer to this is returned to spare memory. Null is
+   --  returned if the pool is set not to store tracebacks. If the traceback
+   --  already existed in the table, the count is incremented so that
+   --  Dump_Tracebacks returns useful results.
+   --  All addresses up to, and including, an address between
+   --  Ignored_Frame_Start .. Ignored_Frame_End are ignored.
+
+   procedure Put_Line
+     (Depth               : Natural;
+      Traceback           : Tracebacks_Array_Access;
+      Ignored_Frame_Start : System.Address := System.Null_Address;
+      Ignored_Frame_End   : System.Address := System.Null_Address);
+   --  Print Traceback to Standard_Output. If Traceback is null, print the
+   --  call_chain at the current location, up to Depth levels, ignoring all
+   --  addresses up to the first one in the range
+   --  Ignored_Frame_Start .. Ignored_Frame_End
+
+   function Is_Valid (Storage : System.Address) return Boolean;
+   pragma Inline (Is_Valid);
+   --  Return True if Storage is an address that the debug pool has under its
+   --  control.
+
+   procedure Set_Valid (Storage : System.Address; Value : Boolean);
+   pragma Inline (Set_Valid);
+   --  Mark the address Storage as being under control of the memory pool (if
+   --  Value is True), or not (if Value is False). This procedure will
+   --  reallocate the table Valid_Blocks as needed.
+
+   procedure Set_Dead_Beef
+     (Storage_Address          : System.Address;
+      Size_In_Storage_Elements : Storage_Count);
+   --  Set the contents of the memory block pointed to by Storage_Address to
+   --  the 16#DEADBEEF# pattern. If Size_In_Storage_Elements is not a multiple
+   --  of the length of this pattern, the last instance may be partial.
+
+   procedure Free_Physically (Pool : in out Debug_Pool);
+   --  Start to physically release some memory to the system, until the amount
+   --  of logically (but not physically) freed memory is lower than the
+   --  expected amount in Pool.
+
+   procedure Allocate_End;
+   procedure Deallocate_End;
+   procedure Dereference_End;
+   --  These procedures are used as markers when computing the stacktraces,
+   --  so that addresses in the debug pool itself are not reported to the user.
+
+   Code_Address_For_Allocate_End    : System.Address;
+   Code_Address_For_Deallocate_End  : System.Address;
+   Code_Address_For_Dereference_End : System.Address;
+   --  Taking the address of the above procedures will not work on some
+   --  architectures (HPUX and VMS for instance). Thus we do the same thing
+   --  that is done in a-except.adb, and get the address of labels instead
+
+   procedure Skip_Levels
+     (Depth               : Natural;
+      Trace               : Tracebacks_Array;
+      Start               : out Natural;
+      Len                 : in out Natural;
+      Ignored_Frame_Start : System.Address;
+      Ignored_Frame_End   : System.Address);
+   --  Set Start .. Len to the range of values from Trace that should be output
+   --  to the user. This range of values exludes any address prior to the first
+   --  one in Ignored_Frame_Start .. Ignored_Frame_End (basically addresses
+   --  internal to this package). Depth is the number of levels that the user
+   --  is interested in.
+
+   ---------------
+   -- Header_Of --
+   ---------------
+
+   function Header_Of (Address : System.Address)
+      return Allocation_Header_Access
+   is
+      function Convert is new Ada.Unchecked_Conversion
+        (System.Address, Allocation_Header_Access);
+   begin
+      return Convert (Address - Minimum_Allocation);
+   end Header_Of;
+
+   --------------
+   -- Set_Next --
+   --------------
+
+   procedure Set_Next
+     (E    : Traceback_Htable_Elem_Ptr;
+      Next : Traceback_Htable_Elem_Ptr)
+   is
+   begin
+      E.Next := Next;
+   end Set_Next;
+
+   ----------
+   -- Next --
+   ----------
+
+   function Next
+     (E    : Traceback_Htable_Elem_Ptr)
+      return Traceback_Htable_Elem_Ptr
+   is
+   begin
+      return E.Next;
+   end Next;
+
+   -----------
+   -- Equal --
+   -----------
+
+   function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean is
+      use Ada.Exceptions.Traceback;
+
+   begin
+      return K1.all = K2.all;
+   end Equal;
+
+   -------------
+   -- Get_Key --
+   -------------
+
+   function Get_Key
+     (E    : Traceback_Htable_Elem_Ptr)
+      return Tracebacks_Array_Access
+   is
+   begin
+      return E.Traceback;
+   end Get_Key;
+
+   ----------
+   -- Hash --
+   ----------
 
-   package Table is new GNAT.HTable.Simple_HTable (
-     Header_Num => Header,
-     Element    => State,
-     No_Element => Not_Allocated,
-     Key        => Address,
-     Hash       => H,
-     Equal      => "=");
+   function Hash (T : Tracebacks_Array_Access) return Header is
+      Result : Integer_Address := 0;
+   begin
+      for X in T'Range loop
+         Result := Result + To_Integer (PC_For (T (X)));
+      end loop;
+      return Header (1 + Result mod Integer_Address (Header'Last));
+   end Hash;
+
+   --------------
+   -- Put_Line --
+   --------------
+
+   procedure Put_Line
+     (Depth               : Natural;
+      Traceback           : Tracebacks_Array_Access;
+      Ignored_Frame_Start : System.Address := System.Null_Address;
+      Ignored_Frame_End   : System.Address := System.Null_Address)
+   is
+      procedure Print (Tr : Tracebacks_Array);
+      --  Print the traceback to standard_output
+
+      -----------
+      -- Print --
+      -----------
+
+      procedure Print (Tr : Tracebacks_Array) is
+      begin
+         for J in Tr'Range loop
+            Put ("0x" & Address_Image (PC_For (Tr (J))) & ' ');
+         end loop;
+         Put (ASCII.LF);
+      end Print;
+
+   --  Start of processing for Put_Line
+
+   begin
+      if Traceback = null then
+         declare
+            Tr  : aliased Tracebacks_Array (1 .. Depth + Max_Ignored_Levels);
+            Start, Len : Natural;
+
+         begin
+            Call_Chain (Tr, Len);
+            Skip_Levels (Depth, Tr, Start, Len,
+                         Ignored_Frame_Start, Ignored_Frame_End);
+            Print (Tr (Start .. Len));
+         end;
+
+      else
+         Print (Traceback.all);
+      end if;
+   end Put_Line;
+
+   -----------------
+   -- Skip_Levels --
+   -----------------
+
+   procedure Skip_Levels
+     (Depth               : Natural;
+      Trace               : Tracebacks_Array;
+      Start               : out Natural;
+      Len                 : in out Natural;
+      Ignored_Frame_Start : System.Address;
+      Ignored_Frame_End   : System.Address)
+   is
+   begin
+      Start := Trace'First;
+
+      while Start <= Len
+        and then (PC_For (Trace (Start)) < Ignored_Frame_Start
+                    or else PC_For (Trace (Start)) > Ignored_Frame_End)
+      loop
+         Start := Start + 1;
+      end loop;
+
+      Start := Start + 1;
+
+      --  Just in case: make sure we have a traceback even if Ignore_Till
+      --  wasn't found.
+
+      if Start > Len then
+         Start := 1;
+      end if;
+
+      if Len - Start + 1 > Depth then
+         Len := Depth + Start - 1;
+      end if;
+   end Skip_Levels;
+
+   ------------------------------
+   -- Find_Or_Create_Traceback --
+   ------------------------------
+
+   function Find_Or_Create_Traceback
+     (Pool                : Debug_Pool;
+      Kind                : Traceback_Kind;
+      Size                : Storage_Count;
+      Ignored_Frame_Start : System.Address;
+      Ignored_Frame_End   : System.Address)
+      return                Traceback_Htable_Elem_Ptr
+   is
+   begin
+      if Pool.Stack_Trace_Depth = 0 then
+         return null;
+      end if;
+
+      declare
+         Trace : aliased Tracebacks_Array
+                  (1 .. Integer (Pool.Stack_Trace_Depth) + Max_Ignored_Levels);
+         Len, Start   : Natural;
+         Elem  : Traceback_Htable_Elem_Ptr;
+
+      begin
+         Call_Chain (Trace, Len);
+         Skip_Levels (Pool.Stack_Trace_Depth, Trace, Start, Len,
+                      Ignored_Frame_Start, Ignored_Frame_End);
+
+         --  Check if the traceback is already in the table.
+
+         Elem :=
+           Backtrace_Htable.Get (Trace (Start .. Len)'Unrestricted_Access);
+
+         --  If not, insert it
+
+         if Elem = null then
+            Elem := new Traceback_Htable_Elem'
+              (Traceback => new Tracebacks_Array'(Trace (Start .. Len)),
+               Count     => 1,
+               Kind      => Kind,
+               Total     => Byte_Count (Size),
+               Next      => null);
+            Backtrace_Htable.Set (Elem);
+
+         else
+            Elem.Count := Elem.Count + 1;
+            Elem.Total := Elem.Total + Byte_Count (Size);
+         end if;
+
+         return Elem;
+      end;
+   end Find_Or_Create_Traceback;
+
+   --------------
+   -- Is_Valid --
+   --------------
+
+   function Is_Valid (Storage : System.Address) return Boolean is
+      Offset : constant Storage_Offset :=
+                 (Storage - Edata) / Default_Alignment;
+
+      Bit : constant Byte := 2 ** Natural (Offset mod System.Storage_Unit);
+
+   begin
+      return (Storage mod Default_Alignment) = 0
+        and then Offset >= 0
+        and then Offset < Valid_Blocks_Size * Storage_Unit
+        and then (Valid_Blocks (Offset / Storage_Unit) and Bit) /= 0;
+   end Is_Valid;
+
+   ---------------
+   -- Set_Valid --
+   ---------------
+
+   procedure Set_Valid (Storage : System.Address; Value : Boolean) is
+      Offset : Storage_Offset;
+      Bit    : Byte;
+      Bytes  : Storage_Offset;
+      Tmp    : constant Table_Ptr := Valid_Blocks;
+
+      Edata_Align : constant Storage_Offset :=
+                      Default_Alignment * Storage_Unit;
+
+      procedure Memset (A : Address; C : Integer; N : size_t);
+      pragma Import (C, Memset, "memset");
+
+      procedure Memmove (Dest, Src : Address; N : size_t);
+      pragma Import (C, Memmove, "memmove");
+
+   begin
+      --  Allocate, or reallocate, the valid blocks table as needed. We start
+      --  with a size big enough to handle Initial_Memory_Size bytes of memory,
+      --  to avoid too many reallocations. The table will typically be around
+      --  16Mb in that case, which is still small enough.
+
+      if Valid_Blocks_Size = 0 then
+         Valid_Blocks_Size := (Initial_Memory_Size / Default_Alignment)
+                                                      / Storage_Unit;
+         Valid_Blocks := To_Pointer (Alloc (size_t (Valid_Blocks_Size)));
+         Edata := Storage;
+
+         --  Reset the memory using memset, which is much faster than the
+         --  standard Ada code with "when others"
+
+         Memset (Valid_Blocks.all'Address, 0, size_t (Valid_Blocks_Size));
+      end if;
+
+      --  First case : the new address is outside of the current scope of
+      --  Valid_Blocks, before the current start address. We need to reallocate
+      --  the table accordingly. This should be a rare occurence, since in most
+      --  cases, the first allocation will also have the lowest address. But
+      --  there is no garantee...
+
+      if Storage < Edata then
+
+         --  The difference between the new Edata and the current one must be
+         --  a multiple of Default_Alignment * Storage_Unit, so that the bit
+         --  representing an address in Valid_Blocks are kept the same.
+
+         Offset := ((Edata - Storage) / Edata_Align + 1) * Edata_Align;
+         Offset := Offset / Default_Alignment;
+         Bytes  := Offset / Storage_Unit;
+         Valid_Blocks :=
+           To_Pointer (Alloc (Size => size_t (Valid_Blocks_Size + Bytes)));
+         Memmove (Dest => Valid_Blocks.all'Address + Bytes,
+                  Src  => Tmp.all'Address,
+                  N    => size_t (Valid_Blocks_Size));
+         Memset (A => Valid_Blocks.all'Address,
+                 C => 0,
+                 N => size_t (Bytes));
+         Free (Tmp.all'Address);
+         Valid_Blocks_Size := Valid_Blocks_Size + Bytes;
+
+         --  Take into the account the new start address
+         Edata := Storage - Edata_Align + (Edata - Storage) mod Edata_Align;
+      end if;
+
+      --  Second case : the new address is outside of the current scope of
+      --  Valid_Blocks, so we have to grow the table as appropriate
+
+      Offset := (Storage - Edata) / Default_Alignment;
+
+      if Offset >= Valid_Blocks_Size * System.Storage_Unit then
+         Bytes := Valid_Blocks_Size;
+         loop
+            Bytes := 2 * Bytes;
+            exit when Offset <= Bytes * System.Storage_Unit;
+         end loop;
+
+         Valid_Blocks := To_Pointer
+           (Realloc (Ptr  => Valid_Blocks.all'Address,
+                     Size => size_t (Bytes)));
+         Memset
+           (Valid_Blocks.all'Address + Valid_Blocks_Size,
+            0,
+            size_t (Bytes - Valid_Blocks_Size));
+         Valid_Blocks_Size := Bytes;
+      end if;
+
+      Bit    := 2 ** Natural (Offset mod System.Storage_Unit);
+      Bytes  := Offset / Storage_Unit;
+
+      --  Then set the value as valid
+
+      if Value then
+         Valid_Blocks (Bytes) := Valid_Blocks (Bytes) or Bit;
+      else
+         Valid_Blocks (Bytes) := Valid_Blocks (Bytes) and (not Bit);
+      end if;
+   end Set_Valid;
 
    --------------
    -- Allocate --
@@ -68,23 +666,399 @@ package body GNAT.Debug_Pools is
       Size_In_Storage_Elements : Storage_Count;
       Alignment                : Storage_Count)
    is
-      pragma Warnings (Off, Alignment);
+      pragma Unreferenced (Alignment);
+      --  Ignored, we always force 'Default_Alignment
+
+      type Local_Storage_Array is new Storage_Array
+        (1 .. Size_In_Storage_Elements + Minimum_Allocation);
+      for Local_Storage_Array'Alignment use Standard'Maximum_Alignment;
+      --  For performance reasons, make sure the alignment is maximized.
+
+      type Ptr is access Local_Storage_Array;
+      --  On some systems, we might want to physically protect pages
+      --  against writing when they have been freed (of course, this is
+      --  expensive in terms of wasted memory). To do that, all we should
+      --  have to do it to set the size of this array to the page size.
+      --  See mprotect().
+
+      P : Ptr;
+
+      Current : Byte_Count;
+      Trace   : Traceback_Htable_Elem_Ptr;
 
    begin
-      Storage_Address := Alloc (size_t (Size_In_Storage_Elements));
+      <<Allocate_Label>>
+      Lock_Task.all;
 
-      if Storage_Address = Null_Address then
-         raise Storage_Error;
-      else
-         Table.Set (Storage_Address, Allocated);
-         Pool.Allocated := Pool.Allocated + Size_In_Storage_Elements;
+      --  If necessary, start physically releasing memory. The reason this is
+      --  done here, although Pool.Logically_Deallocated has not changed above,
+      --  is so that we do this only after a series of deallocations (e.g a
+      --  loop that deallocates a big array). If we were doing that in
+      --  Deallocate, we might be physically freeing memory several times
+      --  during the loop, which is expensive.
 
-         if Pool.Allocated - Pool.Deallocated >  Pool.High_Water then
-            Pool.High_Water := Pool.Allocated - Pool.Deallocated;
-         end if;
+      if Pool.Logically_Deallocated >
+        Byte_Count (Pool.Maximum_Logically_Freed_Memory)
+      then
+         Free_Physically (Pool);
+      end if;
+
+      --  Use standard (ie through malloc) allocations. This automatically
+      --  raises Storage_Error if needed. We also try once more to physically
+      --  release memory, so that even marked blocks, in the advanced scanning,
+      --  are freed.
+
+      begin
+         P := new Local_Storage_Array;
+
+      exception
+         when Storage_Error =>
+            Free_Physically (Pool);
+            P := new Local_Storage_Array;
+      end;
+
+      Storage_Address := P.all'Address + Minimum_Allocation;
+
+      Trace := Find_Or_Create_Traceback
+        (Pool, Alloc, Size_In_Storage_Elements,
+         Allocate_Label'Address, Code_Address_For_Allocate_End);
+
+      pragma Warnings (Off);
+      --  Turn warning on alignment for convert call off. We know that in
+      --  fact this conversion is safe since P itself is always aligned on
+      --  Default_Alignment.
+
+      Header_Of (Storage_Address).all :=
+        (Alloc_Traceback   => Trace,
+         Dealloc_Traceback => To_Traceback (null),
+         Next              => Pool.First_Used_Block,
+         Block_Size        => Size_In_Storage_Elements);
+
+      pragma Warnings (On);
+
+      --  Link this block in the list of used blocks. This will be used to list
+      --  memory leaks in Print_Info, and for the advanced schemes of
+      --  Physical_Free, where we want to traverse all allocated blocks and
+      --  search for possible references.
+
+      --  We insert in front, since most likely we'll be freeing the most
+      --  recently allocated blocks first (the older one might stay allocated
+      --  for the whole life of the application).
+
+      if Pool.First_Used_Block /= System.Null_Address then
+         Header_Of (Pool.First_Used_Block).Dealloc_Traceback :=
+           To_Address (Storage_Address);
+      end if;
+
+      Pool.First_Used_Block := Storage_Address;
+
+      --  Mark the new address as valid
+
+      Set_Valid (Storage_Address, True);
+
+      --  Update internal data
+
+      Pool.Allocated :=
+        Pool.Allocated + Byte_Count (Size_In_Storage_Elements);
+
+      Current := Pool.Allocated -
+                   Pool.Logically_Deallocated -
+                     Pool.Physically_Deallocated;
+
+      if Current > Pool.High_Water then
+         Pool.High_Water := Current;
       end if;
+
+      Unlock_Task.all;
    end Allocate;
 
+   ------------------
+   -- Allocate_End --
+   ------------------
+
+   --  DO NOT MOVE, this must be right after Allocate. This is similar to
+   --  what is done in a-except, so that we can hide the traceback frames
+   --  internal to this package
+
+   procedure Allocate_End is
+   begin
+      <<Allocate_End_Label>>
+      Code_Address_For_Allocate_End := Allocate_End_Label'Address;
+   end Allocate_End;
+
+   -------------------
+   -- Set_Dead_Beef --
+   -------------------
+
+   procedure Set_Dead_Beef
+     (Storage_Address          : System.Address;
+      Size_In_Storage_Elements : Storage_Count)
+   is
+      Dead_Bytes : constant := 4;
+
+      type Data is mod 2 ** (Dead_Bytes * 8);
+      for Data'Size use Dead_Bytes * 8;
+
+      Dead : constant Data := 16#DEAD_BEEF#;
+
+      type Dead_Memory is array
+        (1 .. Size_In_Storage_Elements / Dead_Bytes) of Data;
+      type Mem_Ptr is access Dead_Memory;
+
+      type Byte is mod 2 ** 8;
+      for Byte'Size use 8;
+
+      type Dead_Memory_Bytes is array (0 .. 2) of Byte;
+      type Dead_Memory_Bytes_Ptr is access Dead_Memory_Bytes;
+
+      function From_Ptr is new Ada.Unchecked_Conversion
+        (System.Address, Mem_Ptr);
+
+      function From_Ptr is new Ada.Unchecked_Conversion
+        (System.Address, Dead_Memory_Bytes_Ptr);
+
+      M      : constant Mem_Ptr := From_Ptr (Storage_Address);
+      M2     : Dead_Memory_Bytes_Ptr;
+      Modulo : constant Storage_Count :=
+                 Size_In_Storage_Elements mod Dead_Bytes;
+   begin
+      M.all := (others => Dead);
+
+      --  Any bytes left (up to three of them)
+
+      if Modulo /= 0 then
+         M2 := From_Ptr (Storage_Address + M'Length * Dead_Bytes);
+
+         M2 (0) := 16#DE#;
+         if Modulo >= 2 then
+            M2 (1) := 16#AD#;
+
+            if Modulo >= 3 then
+               M2 (2) := 16#BE#;
+            end if;
+         end if;
+      end if;
+   end Set_Dead_Beef;
+
+   ---------------------
+   -- Free_Physically --
+   ---------------------
+
+   procedure Free_Physically (Pool : in out Debug_Pool) is
+      type Byte is mod 256;
+      type Byte_Access is access Byte;
+
+      function To_Byte is new Ada.Unchecked_Conversion
+        (System.Address, Byte_Access);
+
+      type Address_Access is access System.Address;
+
+      function To_Address_Access is new Ada.Unchecked_Conversion
+        (System.Address, Address_Access);
+
+      In_Use_Mark : constant Byte := 16#D#;
+      Free_Mark   : constant Byte := 16#F#;
+
+      Total_Freed : Storage_Count := 0;
+
+      procedure Reset_Marks;
+      --  Unmark all the logically freed blocks, so that they are considered
+      --  for physical deallocation
+
+      procedure Mark
+        (H : Allocation_Header_Access; A : System.Address; In_Use : Boolean);
+      --  Mark the user data block starting at A. For a block of size zero,
+      --  nothing is done. For a block with a different size, the first byte
+      --  is set to either "D" (in use) or "F" (free).
+
+      function Marked (A : System.Address) return Boolean;
+      --  Return true if the user data block starting at A might be in use
+      --  somewhere else
+
+      procedure Mark_Blocks;
+      --  Traverse all allocated blocks, and search for possible references
+      --  to logically freed blocks. Mark them appropriately
+
+      procedure Free_Blocks (Ignore_Marks : Boolean);
+      --  Physically release blocks. Only the blocks that haven't been marked
+      --  will be released, unless Ignore_Marks is true.
+
+      -----------------
+      -- Free_Blocks --
+      -----------------
+
+      procedure Free_Blocks (Ignore_Marks : Boolean) is
+         Header   : Allocation_Header_Access;
+         Tmp      : System.Address := Pool.First_Free_Block;
+         Next     : System.Address;
+         Previous : System.Address := System.Null_Address;
+
+      begin
+         while Tmp /= System.Null_Address
+           and then Total_Freed < Pool.Minimum_To_Free
+         loop
+            Header := Header_Of (Tmp);
+
+            --  If we know, or at least assume, the block is no longer
+            --  reference anywhere, we can free it physically.
+
+            if Ignore_Marks or else not Marked (Tmp) then
+
+               declare
+                  pragma Suppress (All_Checks);
+                  --  Suppress the checks on this section. If they are overflow
+                  --  errors, it isn't critical, and we'd rather avoid a
+                  --  Constraint_Error in that case.
+               begin
+                  --  Note that block_size < zero for freed blocks
+
+                  Pool.Physically_Deallocated :=
+                    Pool.Physically_Deallocated -
+                      Byte_Count (Header.Block_Size);
+
+                  Pool.Logically_Deallocated :=
+                    Pool.Logically_Deallocated +
+                      Byte_Count (Header.Block_Size);
+
+                  Total_Freed := Total_Freed - Header.Block_Size;
+               end;
+
+               Next := Header.Next;
+               System.Memory.Free (Header.all'Address);
+               Set_Valid (Tmp, False);
+
+               --  Remove this block from the list.
+
+               if Previous = System.Null_Address then
+                  Pool.First_Free_Block := Next;
+               else
+                  Header_Of (Previous).Next := Next;
+               end if;
+
+               Tmp  := Next;
+
+            else
+               Previous := Tmp;
+               Tmp := Header.Next;
+            end if;
+         end loop;
+      end Free_Blocks;
+
+      ----------
+      -- Mark --
+      ----------
+
+      procedure Mark
+        (H      : Allocation_Header_Access;
+         A      : System.Address;
+         In_Use : Boolean)
+      is
+      begin
+         if H.Block_Size /= 0 then
+            if In_Use then
+               To_Byte (A).all := In_Use_Mark;
+            else
+               To_Byte (A).all := Free_Mark;
+            end if;
+         end if;
+      end Mark;
+
+      -----------------
+      -- Mark_Blocks --
+      -----------------
+
+      procedure Mark_Blocks is
+         Tmp      : System.Address := Pool.First_Used_Block;
+         Previous : System.Address;
+         Last     : System.Address;
+         Pointed  : System.Address;
+         Header   : Allocation_Header_Access;
+
+      begin
+         --  For each allocated block, check its contents. Things that look
+         --  like a possible address are used to mark the blocks so that we try
+         --  and keep them, for better detection in case of invalid access.
+         --  This mechanism is far from being fool-proof: it doesn't check the
+         --  stacks of the threads, doesn't check possible memory allocated not
+         --  under control of this debug pool. But it should allow us to catch
+         --  more cases.
+
+         while Tmp /= System.Null_Address loop
+            Previous := Tmp;
+            Last     := Tmp + Header_Of (Tmp).Block_Size;
+            while Previous < Last loop
+               --  ??? Should we move byte-per-byte, or consider that addresses
+               --  are always aligned on 4-bytes boundaries ? Let's use the
+               --  fastest for now.
+
+               Pointed := To_Address_Access (Previous).all;
+               if Is_Valid (Pointed) then
+                  Header := Header_Of (Pointed);
+
+                  --  Do not even attempt to mark blocks in use. That would
+                  --  screw up the whole application, of course.
+                  if Header.Block_Size < 0 then
+                     Mark (Header, Pointed, In_Use => True);
+                  end if;
+               end if;
+
+               Previous := Previous + System.Address'Size;
+            end loop;
+
+            Tmp := Header_Of (Tmp).Next;
+         end loop;
+      end Mark_Blocks;
+
+      ------------
+      -- Marked --
+      ------------
+
+      function Marked (A : System.Address) return Boolean is
+      begin
+         return To_Byte (A).all = In_Use_Mark;
+      end Marked;
+
+      -----------------
+      -- Reset_Marks --
+      -----------------
+
+      procedure Reset_Marks is
+         Current : System.Address := Pool.First_Free_Block;
+         Header  : Allocation_Header_Access;
+
+      begin
+         while Current /= System.Null_Address loop
+            Header := Header_Of (Current);
+            Mark (Header, Current, False);
+            Current := Header.Next;
+         end loop;
+      end Reset_Marks;
+
+   --  Start of processing for Free_Physically
+
+   begin
+      Lock_Task.all;
+
+      if Pool.Advanced_Scanning then
+         Reset_Marks; --  Reset the mark for each freed block
+         Mark_Blocks;
+      end if;
+
+      Free_Blocks (Ignore_Marks => not Pool.Advanced_Scanning);
+
+      --  The contract is that we need to free at least Minimum_To_Free bytes,
+      --  even if this means freeing marked blocks in the advanced scheme
+
+      if Total_Freed < Pool.Minimum_To_Free
+        and then Pool.Advanced_Scanning
+      then
+         Pool.Marked_Blocks_Deallocated := True;
+         Free_Blocks (Ignore_Marks => True);
+      end if;
+
+      Unlock_Task.all;
+   end Free_Physically;
+
    ----------------
    -- Deallocate --
    ----------------
@@ -95,55 +1069,119 @@ package body GNAT.Debug_Pools is
       Size_In_Storage_Elements : Storage_Count;
       Alignment                : Storage_Count)
    is
-      pragma Warnings (Off, Alignment);
+      pragma Unreferenced (Alignment);
+
+      Header   : constant Allocation_Header_Access :=
+        Header_Of (Storage_Address);
+      Valid    : Boolean;
+      Previous : System.Address;
+
+   begin
+      <<Deallocate_Label>>
+      Lock_Task.all;
+      Valid := Is_Valid (Storage_Address);
+
+      if not Valid then
+         Unlock_Task.all;
+         if Pool.Raise_Exceptions then
+            raise Freeing_Not_Allocated_Storage;
+         else
+            Put ("Freeing not allocated storage, at ");
+            Put_Line (Pool.Stack_Trace_Depth, null,
+                      Deallocate_Label'Address,
+                      Code_Address_For_Deallocate_End);
+         end if;
 
-      procedure Free (Address : System.Address; Siz : Storage_Count);
-      --  Fake free, that resets all the deallocated storage to "DEADBEEF"
+      elsif Header.Block_Size < 0 then
+         Unlock_Task.all;
+         if Pool.Raise_Exceptions then
+            raise Freeing_Deallocated_Storage;
+         else
+            Put ("Freeing already deallocated storage, at ");
+            Put_Line (Pool.Stack_Trace_Depth, null,
+                      Deallocate_Label'Address,
+                      Code_Address_For_Deallocate_End);
+            Put ("   Memory already deallocated at ");
+            Put_Line (0, To_Traceback (Header.Dealloc_Traceback).Traceback);
+         end if;
 
-      procedure Free (Address : System.Address; Siz : Storage_Count) is
-         DB1 : constant Integer := 16#DEAD#;
-         DB2 : constant Integer := 16#BEEF#;
+      else
+         --  Remove this block from the list of used blocks.
 
-         type Dead_Memory is array (1 .. Siz / 4) of Integer;
-         type Mem_Ptr is access all Dead_Memory;
+         Previous :=
+           To_Address (Header_Of (Storage_Address).Dealloc_Traceback);
 
-         function From_Ptr is
-           new Unchecked_Conversion (System.Address, Mem_Ptr);
+         if Previous = System.Null_Address then
+            Pool.First_Used_Block := Header_Of (Pool.First_Used_Block).Next;
 
-         J : Storage_Offset;
+            if Pool.First_Used_Block /= System.Null_Address then
+               Header_Of (Pool.First_Used_Block).Dealloc_Traceback :=
+                 To_Traceback (null);
+            end if;
 
-      begin
-         J := Dead_Memory'First;
-         while J < Dead_Memory'Last loop
-            From_Ptr (Address) (J) := DB1;
-            From_Ptr (Address) (J + 1) := DB2;
-            J := J + 2;
-         end loop;
+         else
+            Header_Of (Previous).Next := Header_Of (Storage_Address).Next;
 
-         if J = Dead_Memory'Last then
-            From_Ptr (Address) (J) := DB1;
+            if Header_Of (Storage_Address).Next /= System.Null_Address then
+               Header_Of
+                 (Header_Of (Storage_Address).Next).Dealloc_Traceback :=
+                    To_Address (Previous);
+            end if;
          end if;
-      end Free;
 
-      S : State := Table.Get (Storage_Address);
+         --  Update the header
 
-   --  Start of processing for Deallocate
+         Header.all :=
+           (Alloc_Traceback   => Header.Alloc_Traceback,
+            Dealloc_Traceback => To_Traceback
+                                   (Find_Or_Create_Traceback
+                                      (Pool, Dealloc,
+                                       Size_In_Storage_Elements,
+                                       Deallocate_Label'Address,
+                                       Code_Address_For_Deallocate_End)),
+            Next              => System.Null_Address,
+            Block_Size        => -Size_In_Storage_Elements);
 
-   begin
-      case S is
-         when Not_Allocated =>
-            raise Freeing_Not_Allocated_Storage;
+         if Pool.Reset_Content_On_Free then
+            Set_Dead_Beef (Storage_Address, Size_In_Storage_Elements);
+         end if;
 
-         when Deallocated   =>
-            raise  Freeing_Deallocated_Storage;
+         Pool.Logically_Deallocated :=
+           Pool.Logically_Deallocated +
+             Byte_Count (Size_In_Storage_Elements);
 
-         when Allocated =>
-            Free (Storage_Address, Size_In_Storage_Elements);
-            Table.Set (Storage_Address, Deallocated);
-            Pool.Deallocated := Pool.Deallocated + Size_In_Storage_Elements;
-      end case;
+         --  Link this free block with the others (at the end of the list, so
+         --  that we can start releasing the older blocks first later on).
+
+         if Pool.First_Free_Block = System.Null_Address then
+            Pool.First_Free_Block := Storage_Address;
+            Pool.Last_Free_Block := Storage_Address;
+
+         else
+            Header_Of (Pool.Last_Free_Block).Next := Storage_Address;
+            Pool.Last_Free_Block := Storage_Address;
+         end if;
+
+         --  Do not physically release the memory here, but in Alloc.
+         --  See comment there for details.
+
+         Unlock_Task.all;
+      end if;
    end Deallocate;
 
+   --------------------
+   -- Deallocate_End --
+   --------------------
+
+   --  DO NOT MOVE, this must be right after Deallocate
+   --  See Allocate_End
+
+   procedure Deallocate_End is
+   begin
+      <<Deallocate_End_Label>>
+      Code_Address_For_Deallocate_End := Deallocate_End_Label'Address;
+   end Deallocate_End;
+
    -----------------
    -- Dereference --
    -----------------
@@ -154,68 +1192,238 @@ package body GNAT.Debug_Pools is
       Size_In_Storage_Elements : Storage_Count;
       Alignment                : Storage_Count)
    is
-      pragma Warnings (Off, Pool);
-      pragma Warnings (Off, Size_In_Storage_Elements);
-      pragma Warnings (Off, Alignment);
+      pragma Unreferenced (Alignment, Size_In_Storage_Elements);
 
-      S       : State := Table.Get (Storage_Address);
-      Max_Dim : constant := 3;
-      Dim     : Integer  := 1;
+      Valid   : constant Boolean := Is_Valid (Storage_Address);
+      Header  : Allocation_Header_Access;
 
    begin
+      --  Locking policy: we do not do any locking in this procedure. The
+      --  tables are only read, not written to, and although a problem might
+      --  appear if someone else is modifying the tables at the same time, this
+      --  race condition is not intended to be detected by this storage_pool (a
+      --  now invalid pointer would appear as valid). Instead, we prefer
+      --  optimum performance for dereferences.
 
-      --  If this is not a known address, maybe it is because is is an
-      --  unconstained array. In which case, the bounds have used the
-      --  2 first words (per dimension) of the allocated spot.
-
-      while S = Not_Allocated and then Dim <= Max_Dim loop
-         S := Table.Get (Storage_Address - Storage_Offset (Dim * 2 * 4));
-         Dim := Dim + 1;
-      end loop;
+      <<Dereference_Label>>
 
-      case S is
-         when  Not_Allocated =>
+      if not Valid then
+         if Pool.Raise_Exceptions then
             raise Accessing_Not_Allocated_Storage;
+         else
+            Put ("Accessing not allocated storage, at ");
+            Put_Line (Pool.Stack_Trace_Depth, null,
+                      Dereference_Label'Address,
+                      Code_Address_For_Dereference_End);
+         end if;
 
-         when Deallocated =>
-            raise Accessing_Deallocated_Storage;
+      else
+         Header := Header_Of (Storage_Address);
 
-         when Allocated =>
-            null;
-      end case;
+         if Header.Block_Size < 0 then
+            if Pool.Raise_Exceptions then
+               raise Accessing_Deallocated_Storage;
+            else
+               Put ("Accessing deallocated storage, at ");
+               Put_Line
+                 (Pool.Stack_Trace_Depth, null,
+                  Dereference_Label'Address,
+                  Code_Address_For_Dereference_End);
+               Put ("  First deallocation at ");
+               Put_Line (0, To_Traceback (Header.Dealloc_Traceback).Traceback);
+            end if;
+         end if;
+      end if;
    end Dereference;
 
-   -------
-   -- H --
-   -------
+   ---------------------
+   -- Dereference_End --
+   ---------------------
+
+   --  DO NOT MOVE: this must be right after Dereference
+   --  See Allocate_End
 
-   function H (F : Address) return Header is
+   procedure Dereference_End is
    begin
-      return
-        Header (1 + (To_Integer (F) mod Integer_Address (Header'Last)));
-   end H;
+      <<Dereference_End_Label>>
+      Code_Address_For_Dereference_End := Dereference_End_Label'Address;
+   end Dereference_End;
 
    ----------------
    -- Print_Info --
    ----------------
 
-   procedure Print_Info (Pool : Debug_Pool) is
+   procedure Print_Info
+     (Pool          : Debug_Pool;
+      Cumulate      : Boolean := False;
+      Display_Slots : Boolean := False;
+      Display_Leaks : Boolean := False)
+   is
       use System.Storage_Elements;
 
+      package Backtrace_Htable_Cumulate is new GNAT.HTable.Static_HTable
+        (Header_Num => Header,
+         Element    => Traceback_Htable_Elem,
+         Elmt_Ptr   => Traceback_Htable_Elem_Ptr,
+         Null_Ptr   => null,
+         Set_Next   => Set_Next,
+         Next       => Next,
+         Key        => Tracebacks_Array_Access,
+         Get_Key    => Get_Key,
+         Hash       => Hash,
+         Equal      => Equal);
+      --  This needs a comment ??? probably some of the ones below do too???
+
+      Data    : Traceback_Htable_Elem_Ptr;
+      Elem    : Traceback_Htable_Elem_Ptr;
+      Current : System.Address;
+      Header  : Allocation_Header_Access;
+      K       : Traceback_Kind;
+
    begin
-      Put_Line ("Debug Pool info:");
-      Put_Line ("  Total allocated bytes : "
-        & Storage_Offset'Image (Pool.Allocated));
+      Put_Line
+        ("Total allocated bytes : " &
+         Byte_Count'Image (Pool.Allocated));
 
-      Put_Line ("  Total deallocated bytes : "
-        & Storage_Offset'Image (Pool.Deallocated));
+      Put_Line
+        ("Total logically deallocated bytes : " &
+         Byte_Count'Image (Pool.Logically_Deallocated));
 
-      Put_Line ("  Current Water Mark: "
-        & Storage_Offset'Image (Pool.Allocated - Pool.Deallocated));
+      Put_Line
+        ("Total physically deallocated bytes : " &
+         Byte_Count'Image (Pool.Physically_Deallocated));
+
+      if Pool.Marked_Blocks_Deallocated then
+         Put_Line ("Marked blocks were physically deallocated. This is");
+         Put_Line ("potentially dangereous, and you might want to run");
+         Put_Line ("again with a lower value of Minimum_To_Free");
+      end if;
+
+      Put_Line
+        ("Current Water Mark: " &
+         Byte_Count'Image
+          (Pool.Allocated - Pool.Logically_Deallocated
+                                   - Pool.Physically_Deallocated));
+
+      Put_Line
+        ("High Water Mark: " &
+          Byte_Count'Image (Pool.High_Water));
 
-      Put_Line ("  High Water Mark: "
-        & Storage_Offset'Image (Pool.High_Water));
       Put_Line ("");
+
+      Data := Backtrace_Htable.Get_First;
+      while Data /= null loop
+         if Data.Kind in Alloc .. Dealloc then
+            Elem :=
+              new Traceback_Htable_Elem'
+                   (Traceback => new Tracebacks_Array'(Data.Traceback.all),
+                    Count     => Data.Count,
+                    Kind      => Data.Kind,
+                    Total     => Data.Total,
+                    Next      => null);
+            Backtrace_Htable_Cumulate.Set (Elem);
+
+            if Cumulate then
+               if Data.Kind = Alloc then
+                  K := Indirect_Alloc;
+               else
+                  K := Indirect_Dealloc;
+               end if;
+
+               --  Propagate the direct call to all its parents
+
+               for T in Data.Traceback'First + 1 .. Data.Traceback'Last loop
+                  Elem := Backtrace_Htable_Cumulate.Get
+                    (Data.Traceback
+                       (T .. Data.Traceback'Last)'Unrestricted_Access);
+
+                  --  If not, insert it
+
+                  if Elem = null then
+                     Elem := new Traceback_Htable_Elem'
+                               (Traceback => new Tracebacks_Array'
+                                 (Data.Traceback (T .. Data.Traceback'Last)),
+                        Count     => Data.Count,
+                        Kind      => K,
+                        Total     => Data.Total,
+                        Next      => null);
+                     Backtrace_Htable_Cumulate.Set (Elem);
+
+                     --  Properly take into account that the subprograms
+                     --  indirectly called might be doing either allocations
+                     --  or deallocations. This needs to be reflected in the
+                     --  counts.
+
+                  else
+                     Elem.Count := Elem.Count + Data.Count;
+
+                     if K = Elem.Kind then
+                        Elem.Total := Elem.Total + Data.Total;
+
+                     elsif Elem.Total > Data.Total then
+                        Elem.Total := Elem.Total - Data.Total;
+
+                     else
+                        Elem.Kind  := K;
+                        Elem.Total := Data.Total - Elem.Total;
+                     end if;
+                  end if;
+               end loop;
+            end if;
+
+            Data := Backtrace_Htable.Get_Next;
+         end if;
+      end loop;
+
+      if Display_Slots then
+         Put_Line ("List of allocations/deallocations: ");
+
+         Data := Backtrace_Htable_Cumulate.Get_First;
+         while Data /= null loop
+            case Data.Kind is
+               when Alloc            => Put ("alloc (count:");
+               when Indirect_Alloc   => Put ("indirect alloc (count:");
+               when Dealloc          => Put ("free  (count:");
+               when Indirect_Dealloc => Put ("indirect free  (count:");
+            end case;
+
+            Put (Natural'Image (Data.Count) & ", total:" &
+                 Byte_Count'Image (Data.Total) & ") ");
+
+            for T in Data.Traceback'Range loop
+               Put ("0x" & Address_Image (PC_For (Data.Traceback (T))) & ' ');
+            end loop;
+
+            Put_Line ("");
+
+            Data := Backtrace_Htable_Cumulate.Get_Next;
+         end loop;
+      end if;
+
+      if Display_Leaks then
+         Put_Line ("");
+         Put_Line ("List of not deallocated blocks:");
+
+         --  Do not try to group the blocks with the same stack traces
+         --  together. This is done by the gnatmem output.
+
+         Current := Pool.First_Used_Block;
+         while Current /= System.Null_Address loop
+            Header := Header_Of (Current);
+
+            Put ("Size: " & Storage_Count'Image (Header.Block_Size) & " at: ");
+
+            for T in Header.Alloc_Traceback.Traceback'Range loop
+               Put ("0x" & Address_Image
+                      (PC_For (Header.Alloc_Traceback.Traceback (T))) & ' ');
+            end loop;
+
+            Put_Line ("");
+            Current := Header.Next;
+         end loop;
+      end if;
+
+      Backtrace_Htable_Cumulate.Reset;
    end Print_Info;
 
    ------------------
@@ -223,10 +1431,170 @@ package body GNAT.Debug_Pools is
    ------------------
 
    function Storage_Size (Pool : Debug_Pool) return Storage_Count is
-      pragma Warnings (Off, Pool);
+      pragma Unreferenced (Pool);
 
    begin
       return Storage_Count'Last;
    end Storage_Size;
 
+   ---------------
+   -- Configure --
+   ---------------
+
+   procedure Configure
+     (Pool                           : in out Debug_Pool;
+      Stack_Trace_Depth              : Natural := Default_Stack_Trace_Depth;
+      Maximum_Logically_Freed_Memory : SSC     := Default_Max_Freed;
+      Minimum_To_Free                : SSC     := Default_Min_Freed;
+      Reset_Content_On_Free          : Boolean := Default_Reset_Content;
+      Raise_Exceptions               : Boolean := Default_Raise_Exceptions;
+      Advanced_Scanning              : Boolean := Default_Advanced_Scanning)
+   is
+   begin
+      Pool.Stack_Trace_Depth              := Stack_Trace_Depth;
+      Pool.Maximum_Logically_Freed_Memory := Maximum_Logically_Freed_Memory;
+      Pool.Reset_Content_On_Free          := Reset_Content_On_Free;
+      Pool.Raise_Exceptions               := Raise_Exceptions;
+      Pool.Minimum_To_Free                := Minimum_To_Free;
+      Pool.Advanced_Scanning              := Advanced_Scanning;
+   end Configure;
+
+   ----------------
+   -- Print_Pool --
+   ----------------
+
+   procedure Print_Pool (A : System.Address) is
+      Storage : constant Address := A;
+      Valid   : constant Boolean := Is_Valid (Storage);
+      Header  : Allocation_Header_Access;
+
+   begin
+      --  We might get Null_Address if the call from gdb was done
+      --  incorrectly. For instance, doing a "print_pool(my_var)" passes 0x0,
+      --  instead of passing the value of my_var
+
+      if A = System.Null_Address then
+         Put_Line ("Memory not under control of the storage pool");
+         return;
+      end if;
+
+      if not Valid then
+         Put_Line ("Memory not under control of the storage pool");
+
+      else
+         Header := Header_Of (Storage);
+         Put_Line ("0x" & Address_Image (A)
+                     & " allocated at:");
+         Put_Line (0, Header.Alloc_Traceback.Traceback);
+
+         if To_Traceback (Header.Dealloc_Traceback) /= null then
+            Put_Line ("0x" & Address_Image (A)
+                      & " logically freed memory, deallocated at:");
+            Put_Line (0, To_Traceback (Header.Dealloc_Traceback).Traceback);
+         end if;
+      end if;
+   end Print_Pool;
+
+   -----------------------
+   -- Print_Info_Stdout --
+   -----------------------
+
+   procedure Print_Info_Stdout
+     (Pool          : Debug_Pool;
+      Cumulate      : Boolean := False;
+      Display_Slots : Boolean := False;
+      Display_Leaks : Boolean := False)
+   is
+      procedure Internal is new Print_Info
+        (Put_Line => GNAT.IO.Put_Line,
+         Put      => GNAT.IO.Put);
+
+   begin
+      Internal (Pool, Cumulate, Display_Slots, Display_Leaks);
+   end Print_Info_Stdout;
+
+   ------------------
+   -- Dump_Gnatmem --
+   ------------------
+
+   procedure Dump_Gnatmem (Pool : Debug_Pool; File_Name : String) is
+      type File_Ptr is new System.Address;
+
+      function fopen (Path : String; Mode : String) return File_Ptr;
+      pragma Import (C, fopen);
+
+      procedure fwrite
+        (Ptr    : System.Address;
+         Size   : size_t;
+         Nmemb  : size_t;
+         Stream : File_Ptr);
+
+      procedure fwrite
+        (Str    : String;
+         Size   : size_t;
+         Nmemb  : size_t;
+         Stream : File_Ptr);
+      pragma Import (C, fwrite);
+
+      procedure fputc (C : Integer; Stream : File_Ptr);
+      pragma Import (C, fputc);
+
+      procedure fclose (Stream : File_Ptr);
+      pragma Import (C, fclose);
+
+      Address_Size : constant size_t :=
+                       System.Address'Max_Size_In_Storage_Elements;
+      --  Size in bytes of a pointer
+
+      File        : File_Ptr;
+      Current     : System.Address;
+      Header      : Allocation_Header_Access;
+      Actual_Size : size_t;
+      Num_Calls   : Integer;
+      Tracebk     : Tracebacks_Array_Access;
+
+   begin
+      File := fopen (File_Name & ASCII.NUL, "wb" & ASCII.NUL);
+      fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, File);
+
+      --  List of not deallocated blocks (see Print_Info)
+
+      Current := Pool.First_Used_Block;
+      while Current /= System.Null_Address loop
+         Header := Header_Of (Current);
+
+         Actual_Size := size_t (Header.Block_Size);
+         Tracebk := Header.Alloc_Traceback.Traceback;
+         Num_Calls := Tracebk'Length;
+
+         --  Code taken from memtrack.adb in GNAT's sources
+         --  Logs allocation call
+         --  format is:
+         --   'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
+
+         fputc (Character'Pos ('A'), File);
+         fwrite (Current'Address, Address_Size, 1, File);
+         fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1,
+                 File);
+         fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
+                 File);
+
+         for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
+            declare
+               Ptr : System.Address := PC_For (Tracebk (J));
+            begin
+               fwrite (Ptr'Address, Address_Size, 1, File);
+            end;
+         end loop;
+
+         Current := Header.Next;
+      end loop;
+
+      fclose (File);
+   end Dump_Gnatmem;
+
+begin
+   Allocate_End;
+   Deallocate_End;
+   Dereference_End;
 end GNAT.Debug_Pools;